diff options
author | Todd C. Miller <millert@cvs.openbsd.org> | 1997-11-30 08:07:08 +0000 |
---|---|---|
committer | Todd C. Miller <millert@cvs.openbsd.org> | 1997-11-30 08:07:08 +0000 |
commit | ec01b9db009b90979fb9d6b514d483a54d3d5bdd (patch) | |
tree | 644294037f797fdbdcbe608141f083e078a41d46 /gnu/usr.bin/perl | |
parent | 0512af39306262113602b12265059e76c91427ff (diff) |
perl5.005_03
Diffstat (limited to 'gnu/usr.bin/perl')
92 files changed, 21472 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/t/lib/io_dup.t b/gnu/usr.bin/perl/t/lib/io_dup.t new file mode 100644 index 00000000000..6b0caf14fad --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_dup.t @@ -0,0 +1,61 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Handle; +use IO::File; + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..6\n"; + +print "ok 1\n"; + +$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w"); +$duperr = IO::Handle->new->fdopen( \*STDERR ,"w"); + +$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle"; +$stderr = \*STDERR; bless $stderr, "IO::Handle"; + +$stdout->open( "Io.dup","w") || die "Can't open stdout"; +$stderr->fdopen($stdout,"w"); + +print $stdout "ok 2\n"; +print $stderr "ok 3\n"; +if ($^O eq 'MSWin32') { + print `echo ok 4`; + print `echo ok 5 1>&2`; # does this *really* work? +} +else { + system 'echo ok 4'; + system 'echo ok 5 1>&2'; +} + +$stderr->close; +$stdout->close; + +$stdout->fdopen($dupout,"w"); +$stderr->fdopen($duperr,"w"); + +if ($^O eq 'MSWin32') { print `type Io.dup` } +else { system 'cat Io.dup' } +unlink 'Io.dup'; + +print STDOUT "ok 6\n"; diff --git a/gnu/usr.bin/perl/t/lib/io_pipe.t b/gnu/usr.bin/perl/t/lib/io_pipe.t new file mode 100644 index 00000000000..eee374149ca --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_pipe.t @@ -0,0 +1,109 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if (! $Config{'d_fork'} || + ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS')) + { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Pipe; + +my $perl = './perl'; + +$| = 1; +print "1..10\n"; + +$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"'); +while (<$pipe>) { + s/^not //; + print; +} +$pipe->close or print "# \$!=$!\nnot "; +print "ok 2\n"; + +$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //'; +$pipe = new IO::Pipe->writer($perl, '-pe', $cmd); +print $pipe "not ok 3\n" ; +$pipe->close or print "# \$!=$!\nnot "; +print "ok 4\n"; + +$pipe = new IO::Pipe; + +$pid = fork(); + +if($pid) + { + $pipe->writer; + print $pipe "Xk 5\n"; + print $pipe "oY 6\n"; + $pipe->close; + wait; + } +elsif(defined $pid) + { + $pipe->reader; + $stdin = bless \*STDIN, "IO::Handle"; + $stdin->fdopen($pipe,"r"); + exec 'tr', 'YX', 'ko'; + } +else + { + die "# error = $!"; + } + +$pipe = new IO::Pipe; +$pid = fork(); + +if($pid) + { + $pipe->reader; + while(<$pipe>) { + s/^not //; + print; + } + $pipe->close; + wait; + } +elsif(defined $pid) + { + $pipe->writer; + + $stdout = bless \*STDOUT, "IO::Handle"; + $stdout->fdopen($pipe,"w"); + print STDOUT "not ok 7\n"; + exec 'echo', 'not ok 8'; + } +else + { + die; + } + +$pipe = new IO::Pipe; +$pipe->writer; + +$SIG{'PIPE'} = 'broken_pipe'; + +sub broken_pipe { + print "ok 9\n"; +} + +print $pipe "not ok 9\n"; +$pipe->close; + + +print "ok 10\n"; + diff --git a/gnu/usr.bin/perl/t/lib/io_sel.t b/gnu/usr.bin/perl/t/lib/io_sel.t new file mode 100644 index 00000000000..b9c10974040 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_sel.t @@ -0,0 +1,116 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..21\n"; + +use IO::Select 1.09; + +my $sel = new IO::Select(\*STDIN); +$sel->add(4, 5) == 2 or print "not "; +print "ok 1\n"; + +$sel->add([\*STDOUT, 'foo']) == 1 or print "not "; +print "ok 2\n"; + +@handles = $sel->handles; +print "not " unless $sel->count == 4 && @handles == 4; +print "ok 3\n"; +#print $sel->as_string, "\n"; + +$sel->remove(\*STDIN) == 1 or print "not "; +print "ok 4\n", +; +$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present + or print "not "; +print "ok 5\n"; + +print "not " unless $sel->count == 2; +print "ok 6\n"; +#print $sel->as_string, "\n"; + +$sel->remove(1, 4); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 7\n"; + +$sel = new IO::Select; +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 8\n"; + +$sel->remove([\*STDOUT, 5]); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 9\n"; + +if ($^O eq 'MSWin32') { # 4-arg select is only valid on sockets + print "# skipping tests 10..15\n"; + for (10 .. 15) { print "ok $_\n" } + $sel->add(\*STDOUT); # update + goto POST_SOCKET; +} + +@a = $sel->can_read(); # should return imediately +print "not " unless @a == 0; +print "ok 10\n"; + +# we assume that we can write to STDOUT :-) +$sel->add([\*STDOUT, "ok 12\n"]); + +@a = $sel->can_write; +print "not " unless @a == 1; +print "ok 11\n"; + +my($fd, $msg) = @{shift @a}; +print $fd $msg; + +$sel->add(\*STDOUT); # update + +@a = IO::Select::select(undef, $sel, undef, 1); +print "not " unless @a == 3; +print "ok 13\n"; + +($r, $w, $e) = @a; + +print "not " unless @$r == 0 && @$w == 1 && @$e == 0; +print "ok 14\n"; + +$fd = $w->[0]; +print $fd "ok 15\n"; + +POST_SOCKET: +# Test new exists() method +$sel->exists(\*STDIN) and print "not "; +print "ok 16\n"; + +($sel->exists(0) || $sel->exists([\*STDERR])) and print "not "; +print "ok 17\n"; + +$fd = $sel->exists(\*STDOUT); +if ($fd) { + print $fd "ok 18\n"; +} else { + print "not ok 18\n"; +} + +$fd = $sel->exists([1, 'foo']); +if ($fd) { + print $fd "ok 19\n"; +} else { + print "not ok 19\n"; +} + +# Try self clearing +$sel->add(5,6,7,8,9,10); +print "not " unless $sel->count == 7; +print "ok 20\n"; + +$sel->remove($sel->handles); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 21\n"; diff --git a/gnu/usr.bin/perl/t/lib/io_sock.t b/gnu/usr.bin/perl/t/lib/io_sock.t new file mode 100644 index 00000000000..0971e7803f0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_sock.t @@ -0,0 +1,81 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if (-d "lib" && -f "TEST") { + if (!$Config{'d_fork'} || + (($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/) && + !(($^O eq 'VMS') && $Config{d_socket}))) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..5\n"; + +use IO::Socket; + +$listen = IO::Socket::INET->new(Listen => 2, + Proto => 'tcp', + ) or die "$!"; + +print "ok 1\n"; + +$port = $listen->sockport; + +if($pid = fork()) { + + $sock = $listen->accept(); + print "ok 2\n"; + + $sock->autoflush(1); + print $sock->getline(); + + print $sock "ok 4\n"; + + $sock->close; + + waitpid($pid,0); + + print "ok 5\n"; + +} elsif(defined $pid) { + + # This can fail if localhost is undefined or the + # special 'loopback' address 127.0.0.1 is not configured + # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + + $sock = IO::Socket::INET->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => 'localhost' + ) or die "$!"; + + $sock->autoflush(1); + + print $sock "ok 3\n"; + + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} + + + + + + diff --git a/gnu/usr.bin/perl/t/lib/io_taint.t b/gnu/usr.bin/perl/t/lib/io_taint.t new file mode 100644 index 00000000000..0ef2cfd63f5 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_taint.t @@ -0,0 +1,48 @@ +#!./perl -T + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +END { unlink "./__taint__$$" } + +print "1..3\n"; +use IO::File; +$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +print $x "$$\n"; +$x->close; + +$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +chop($unsafe = <$x>); +eval { kill 0 * $unsafe }; +print "not " if $^O ne 'MSWin32' and ($@ !~ /^Insecure/o); +print "ok 1\n"; +$x->close; + +# We could have just done a seek on $x, but technically we haven't tested +# seek yet... +$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +$x->untaint; +print "not " if ($?); +print "ok 2\n"; # Calling the method worked +chop($unsafe = <$x>); +eval { kill 0 * $unsafe }; +print "not " if ($@ =~ /^Insecure/o); +print "ok 3\n"; # No Insecure message from using the data +$x->close; + +exit 0; diff --git a/gnu/usr.bin/perl/t/lib/io_tell.t b/gnu/usr.bin/perl/t/lib/io_tell.t new file mode 100644 index 00000000000..d8ebae24fd0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_tell.t @@ -0,0 +1,64 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + $tell_file = "TEST"; + } + else { + $tell_file = "Makefile"; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +print "1..13\n"; + +use IO::File; + +$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); +binmode $tst if $^O eq 'MSWin32'; +if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } + +$firstline = <$tst>; +$secondpos = tell; + +$x = 0; +while (<$tst>) { + if (eof) {$x++;} +} +if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } + +$lastpos = tell; + +unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } + +if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } + +if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } + +if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; } + +if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } + +if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } + +if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; } + +if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } + +if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } + +if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; } + +unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } diff --git a/gnu/usr.bin/perl/t/lib/io_udp.t b/gnu/usr.bin/perl/t/lib/io_udp.t new file mode 100644 index 00000000000..3e167141182 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_udp.t @@ -0,0 +1,44 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ( ($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/ || + $^O eq 'os2') && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..3\n"; + +use Socket; +use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); + + # This can fail if localhost is undefined or the + # special 'loopback' address 127.0.0.1 is not configured + # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + +$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); +$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); + +print "ok 1\n"; + +$udpa->send("ok 2\n",0,$udpb->sockname); +$udpb->recv($buf="",5); +print $buf; +$udpb->send("ok 3\n"); +$udpa->recv($buf="",5); +print $buf; diff --git a/gnu/usr.bin/perl/t/lib/io_xs.t b/gnu/usr.bin/perl/t/lib/io_xs.t new file mode 100644 index 00000000000..1a6fd381a30 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_xs.t @@ -0,0 +1,42 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::File; +use IO::Seekable; + +print "1..4\n"; + +$x = new_tmpfile IO::File or print "not "; +print "ok 1\n"; +print $x "ok 2\n"; +$x->seek(0,SEEK_SET); +print <$x>; + +$x->seek(0,SEEK_SET); +print $x "not ok 3\n"; +$p = $x->getpos; +print $x "ok 3\n"; +$x->flush; +$x->setpos($p); +print scalar <$x>; + +$! = 0; +$x->setpos(undef); +print $! ? "ok 4 # $!\n" : "not ok 4\n"; diff --git a/gnu/usr.bin/perl/t/lib/opcode.t b/gnu/usr.bin/perl/t/lib/opcode.t new file mode 100644 index 00000000000..a785fce48b6 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/opcode.t @@ -0,0 +1,115 @@ +#!./perl -w + +$|=1; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +use Opcode qw( + opcodes opdesc opmask verify_opset + opset opset_to_ops opset_to_hex invert_opset + opmask_add full_opset empty_opset define_optag +); + +use strict; + +my $t = 1; +my $last_test; # initalised at end +print "1..$last_test\n"; + +my($s1, $s2, $s3); +my(@o1, @o2, @o3); + +# --- opset_to_ops and opset + +my @empty_l = opset_to_ops(empty_opset); +print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; + +my @full_l1 = opset_to_ops(full_opset); +print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; +my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed +print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++; + +@empty_l = opset_to_ops(opset(':none')); +print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; + +my @full_l3 = opset_to_ops(opset(':all')); +print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++; +print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++; + +die $t unless $t == 7; +$s1 = opset( 'padsv'); +$s2 = opset($s1, 'padav'); +$s3 = opset($s2, '!padav'); +print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t; +print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t; + +# --- define_optag + +print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t; +define_optag(":_tst_", opset(qw(padsv padav padhv))); +print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t; + +# --- opdesc and opcodes + +die $t unless $t == 11; +print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++; +my @desc = opdesc(':_tst_','stub'); +print "@desc" eq "private variable private array private hash stub" + ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++; +print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; +print "ok $t\n"; ++$t; + +# --- invert_opset + +$s1 = opset(qw(fileno padsv padav)); +@o2 = opset_to_ops(invert_opset($s1)); +print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++; + +# --- opmask + +die $t unless $t == 16; +print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work +print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++; + +# --- verify_opset + +print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++; + +# --- opmask_add + +opmask_add(opset(qw(fileno))); # add to global op_mask +print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail +print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++; + +# --- check use of bit vector ops on opsets + +$s1 = opset('padsv'); +$s2 = opset('padav'); +$s3 = opset('padsv', 'padav', 'padhv'); + +# Non-negated +print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++; +print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++; +print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++; + +# Negated, e.g., with possible extra bits in last byte beyond last op bit. +# The extra bits mean we can't just say ~mask eq invert_opset(mask). + +@o1 = opset_to_ops( ~ $s3); +@o2 = opset_to_ops(invert_opset $s3); +print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++; + +# --- finally, check some opname assertions + +foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ } + +print "ok $last_test\n"; +BEGIN { $last_test = 25 } diff --git a/gnu/usr.bin/perl/t/lib/open2.t b/gnu/usr.bin/perl/t/lib/open2.t new file mode 100644 index 00000000000..a2e6a07a7b0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/open2.t @@ -0,0 +1,46 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use strict; +use IO::Handle; +use IPC::Open2; +#require 'open2.pl'; use subs 'open2'; + +my $perl = './perl'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..7\n"; + +ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', 'print scalar <STDIN>'; +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, close(WRITE), $!; +ok 5, close(READ), $!; +$reaped_pid = waitpid $pid, 0; +ok 6, $reaped_pid == $pid, $reaped_pid; +ok 7, $? == 0, $?; diff --git a/gnu/usr.bin/perl/t/lib/open3.t b/gnu/usr.bin/perl/t/lib/open3.t new file mode 100644 index 00000000000..4258eec4018 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/open3.t @@ -0,0 +1,121 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use strict; +use IO::Handle; +use IPC::Open3; +#require 'open3.pl'; use subs 'open3'; + +my $perl = './perl'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..21\n"; + +# basic +ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR "hi error\n"; +EOF +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, <ERROR> eq "hi error\n"; +ok 5, close(WRITE), $!; +ok 6, close(READ), $!; +ok 7, close(ERROR), $!; +$reaped_pid = waitpid $pid, 0; +ok 8, $reaped_pid == $pid, $reaped_pid; +ok 9, $? == 0, $?; + +# read and error together, both named +$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 10\n"; +print scalar <READ>; +print WRITE "ok 11\n"; +print scalar <READ>; +waitpid $pid, 0; + +# read and error together, error empty +$pid = open3 'WRITE', 'READ', '', $perl, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 12\n"; +print scalar <READ>; +print WRITE "ok 13\n"; +print scalar <READ>; +waitpid $pid, 0; + +# dup writer +ok 14, pipe PIPE_READ, PIPE_WRITE; +$pid = open3 '<&PIPE_READ', 'READ', '', + $perl, '-e', 'print scalar <STDIN>'; +close PIPE_READ; +print PIPE_WRITE "ok 15\n"; +close PIPE_WRITE; +print scalar <READ>; +waitpid $pid, 0; + +# dup reader +$pid = open3 'WRITE', '>&STDOUT', 'ERROR', + $perl, '-e', 'print scalar <STDIN>'; +print WRITE "ok 16\n"; +waitpid $pid, 0; + +# dup error: This particular case, duping stderr onto the existing +# stdout but putting stdout somewhere else, is a good case because it +# used not to work. +$pid = open3 'WRITE', 'READ', '>&STDOUT', + $perl, '-e', 'print STDERR scalar <STDIN>'; +print WRITE "ok 17\n"; +waitpid $pid, 0; + +# dup reader and error together, both named +$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 18\n"; +print WRITE "ok 19\n"; +waitpid $pid, 0; + +# dup reader and error together, error empty +$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 20\n"; +print WRITE "ok 21\n"; +waitpid $pid, 0; diff --git a/gnu/usr.bin/perl/t/lib/ops.t b/gnu/usr.bin/perl/t/lib/ops.t new file mode 100644 index 00000000000..56b1bacabb0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/ops.t @@ -0,0 +1,29 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +print "1..2\n"; + +eval <<'EOP'; + no ops 'fileno'; # equiv to "perl -M-ops=fileno" + $a = fileno STDIN; +EOP + +print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n"; + +eval <<'EOP'; + use ops ':default'; # equiv to "perl -M(as above) -Mops=:default" + eval 1; +EOP + +print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n"; + +1; diff --git a/gnu/usr.bin/perl/t/lib/parsewords.t b/gnu/usr.bin/perl/t/lib/parsewords.t new file mode 100644 index 00000000000..47a75881dc7 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/parsewords.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..4\n"; + +use Text::ParseWords; + +@words = shellwords(qq(foo "bar quiz" zoo)); +#print join(";", @words), "\n"; + +print "not " if $words[0] ne 'foo'; +print "ok 1\n"; + +print "not " if $words[1] ne 'bar quiz'; +print "ok 2\n"; + +print "not " if $words[2] ne 'zoo'; +print "ok 3\n"; + +# Test quotewords() with other parameters +@words = quotewords(":+", 1, qq(foo:::"bar:foo":zoo zoo:)); +#print join(";", @words), "\n"; +print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo); +print "ok 4\n"; diff --git a/gnu/usr.bin/perl/t/lib/safe1.t b/gnu/usr.bin/perl/t/lib/safe1.t new file mode 100644 index 00000000000..27993d95c9f --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/safe1.t @@ -0,0 +1,68 @@ +#!./perl -w +$|=1; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +# Tests Todo: +# 'main' as root + +package test; # test from somewhere other than main + +use vars qw($bar); + +use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex + opmask_add full_opset empty_opset opcodes opmask define_optag); + +use Safe 1.00; + +my $last_test; # initalised at end +print "1..$last_test\n"; + +my $t = 1; +my $cpt; +# create and destroy some automatic Safe compartments first +$cpt = new Safe or die; +$cpt = new Safe or die; +$cpt = new Safe or die; + +$cpt = new Safe "Root" or die; + +foreach(1..3) { + $foo = 42; + + $cpt->share(qw($foo)); + + print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++; + + ${$cpt->varglob('foo')} = 9; + + print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + + print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + # check 'main' has been changed: + print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + # check we can't see our test package: + print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++; + print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++; + + $cpt->erase; # erase the compartment, e.g., delete all variables + + print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++; + + # Note that we *must* use $cpt->varglob here because if we used + # $Root::foo etc we would still see the original values! + # This seems to be because the compiler has created an extra ref. + + print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++; +} + +print "ok $last_test\n"; +BEGIN { $last_test = 28 } diff --git a/gnu/usr.bin/perl/t/lib/safe2.t b/gnu/usr.bin/perl/t/lib/safe2.t new file mode 100644 index 00000000000..40c50980580 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/safe2.t @@ -0,0 +1,144 @@ +#!./perl -w +$|=1; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } + # test 30 rather naughtily expects English error messages + $ENV{'LC_ALL'} = 'C'; +} + +# Tests Todo: +# 'main' as root + +use vars qw($bar); + +use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex + opmask_add full_opset empty_opset opcodes opmask define_optag); + +use Safe 1.00; + +my $last_test; # initalised at end +print "1..$last_test\n"; + +# Set up a package namespace of things to be visible to the unsafe code +$Root::foo = "visible"; +$bar = "invisible"; + +# Stop perl from moaning about identifies which are apparently only used once +$Root::foo .= ""; + +my $cpt; +# create and destroy a couple of automatic Safe compartments first +$cpt = new Safe or die; +$cpt = new Safe or die; + +$cpt = new Safe "Root"; + +$cpt->reval(q{ system("echo not ok 1"); }); +if ($@ =~ /^system trapped by operation mask/) { + print "ok 1\n"; +} else { + print "#$@" if $@; + print "not ok 1\n"; +} + +$cpt->reval(q{ + print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n"; + print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n"; + print defined($bar) ? "not ok 4\n" : "ok 4\n"; + print defined($::bar) ? "not ok 5\n" : "ok 5\n"; + print defined($main::bar) ? "not ok 6\n" : "ok 6\n"; +}); +print $@ ? "not ok 7\n#$@" : "ok 7\n"; + +$foo = "ok 8\n"; +%bar = (key => "ok 9\n"); +@baz = (); push(@baz, "o", "10"); $" = 'k '; +$glob = "ok 11\n"; +@glob = qw(not ok 16); + +sub sayok { print "ok @_\n" } + +$cpt->share(qw($foo %bar @baz *glob sayok $")); + +$cpt->reval(q{ + package other; + sub other_sayok { print "ok @_\n" } + package main; + print $foo ? $foo : "not ok 8\n"; + print $bar{key} ? $bar{key} : "not ok 9\n"; + (@baz) ? print "@baz\n" : print "not ok 10\n"; + print $glob; + other::other_sayok(12); + $foo =~ s/8/14/; + $bar{new} = "ok 15\n"; + @glob = qw(ok 16); +}); +print $@ ? "not ok 13\n#$@" : "ok 13\n"; +$" = ' '; +print $foo, $bar{new}, "@glob\n"; + +$Root::foo = "not ok 17"; +@{$cpt->varglob('bar')} = qw(not ok 18); +${$cpt->varglob('foo')} = "ok 17"; +@Root::bar = "ok"; +push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." + +print "$Root::foo\n"; +print "@{$cpt->varglob('bar')}\n"; + +use strict; + +print 1 ? "ok 19\n" : "not ok 19\n"; +print 1 ? "ok 20\n" : "not ok 20\n"; + +my $m1 = $cpt->mask; +$cpt->trap("negate"); +my $m2 = $cpt->mask; +my @masked = opset_to_ops($m1); +print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n"; + +print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n"; + +print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; + +$cpt->mask(empty_opset); +my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"'); +print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n"; +my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)'); +print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n"; + +my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); +print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n"; +print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; + +# --- rdo + +my $t = 30; +$cpt->rdo('/non/existant/file.name'); +print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || + $! =~ /A file or directory in the path name does not exist/ || + $! =~ /Device not configured/ ? + "ok $t\n" : "not ok $t # $!\n"); $t++; +print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; + +#my $rdo_file = "tmp_rdo.tpl"; +#if (open X,">$rdo_file") { +# print X "999\n"; +# close X; +# $cpt->permit_only('const', 'leaveeval'); +# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; +# unlink $rdo_file; +#} +#else { +# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; +#} + + +print "ok $last_test\n"; +BEGIN { $last_test = 32 } diff --git a/gnu/usr.bin/perl/t/lib/searchdict.t b/gnu/usr.bin/perl/t/lib/searchdict.t new file mode 100644 index 00000000000..447c425b276 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/searchdict.t @@ -0,0 +1,65 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +$DICT = <<EOT; +Aarhus +Aaron +Ababa +aback +abaft +abandon +abandoned +abandoning +abandonment +abandons +abase +abased +abasement +abasements +abases +abash +abashed +abashes +abashing +abasing +abate +abated +abatement +abatements +abater +abates +abating +Abba +EOT + +use Search::Dict; + +open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; +binmode DICT; # To make length expected one. +print DICT $DICT; + +my $pos = look *DICT, "abash"; +chomp($word = <DICT>); +print "not " if $pos < 0 || $word ne "abash"; +print "ok 1\n"; + +$pos = look *DICT, "foo"; +chomp($word = <DICT>); + +print "not " if $pos != length($DICT); # will search to end of file +print "ok 2\n"; + +$pos = look *DICT, "aarhus", 1, 1; +chomp($word = <DICT>); + +print "not " if $pos < 0 || $word ne "Aarhus"; +print "ok 3\n"; + +close DICT or die "cannot close"; +unlink "dict-$$"; diff --git a/gnu/usr.bin/perl/t/lib/selectsaver.t b/gnu/usr.bin/perl/t/lib/selectsaver.t new file mode 100644 index 00000000000..3b58d709ab3 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/selectsaver.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +use SelectSaver; + +open(FOO, ">foo-$$") || die; + +print "ok 1\n"; +{ + my $saver = new SelectSaver(FOO); + print "foo\n"; +} + +# Get data written to file +open(FOO, "foo-$$") || die; +chomp($foo = <FOO>); +close FOO; +unlink "foo-$$"; + +print "ok 2\n" if $foo eq "foo"; + +print "ok 3\n"; diff --git a/gnu/usr.bin/perl/t/lib/symbol.t b/gnu/usr.bin/perl/t/lib/symbol.t new file mode 100644 index 00000000000..03449a3ed74 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/symbol.t @@ -0,0 +1,52 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..8\n"; + +BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_ + +use Symbol; + +# First check $_ clobbering +print "not " if $_ ne 'foo'; +print "ok 1\n"; + + +# First test gensym() +$sym1 = gensym; +print "not " if ref($sym1) ne 'GLOB'; +print "ok 2\n"; + +$sym2 = gensym; + +print "not " if $sym1 eq $sym2; +print "ok 3\n"; + +ungensym $sym1; + +$sym1 = $sym2 = undef; + + +# Test qualify() +package foo; + +use Symbol qw(qualify); # must import into this package too + +qualify("x") eq "foo::x" or print "not "; +print "ok 4\n"; + +qualify("x", "FOO") eq "FOO::x" or print "not "; +print "ok 5\n"; + +qualify("BAR::x") eq "BAR::x" or print "not "; +print "ok 6\n"; + +qualify("STDOUT") eq "main::STDOUT" or print "not "; +print "ok 7\n"; + +qualify("ARGV", "FOO") eq "main::ARGV" or print "not "; +print "ok 8\n"; diff --git a/gnu/usr.bin/perl/t/lib/texttabs.t b/gnu/usr.bin/perl/t/lib/texttabs.t new file mode 100644 index 00000000000..ea9012c6526 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/texttabs.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +use Text::Tabs; + +$tabstop = 4; + +$s1 = "foo\tbar\tb\tb"; +$s2 = expand $s1; +$s3 = unexpand $s2; + +print "not " unless $s2 eq "foo bar b b"; +print "ok 1\n"; + +print "not " unless $s3 eq "foo bar b\tb"; +print "ok 2\n"; + + +$tabstop = 8; + +print "not " unless unexpand(" foo") eq "\t\t foo"; +print "ok 3\n"; diff --git a/gnu/usr.bin/perl/t/lib/textwrap.t b/gnu/usr.bin/perl/t/lib/textwrap.t new file mode 100644 index 00000000000..9c8d1b49756 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/textwrap.t @@ -0,0 +1,40 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..5\n"; + +use Text::Wrap qw(wrap $columns); + +$columns = 30; + +$text = <<'EOT'; +Text::Wrap is a very simple paragraph formatter. It formats a +single paragraph at a time by breaking lines at word boundries. +Indentation is controlled for the first line ($initial_tab) and +all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns +should be set to the full width of your output device. +EOT + +$text =~ s/\n/ /g; +$_ = wrap "| ", "|", $text; + +#print "$_\n"; + +print "not " unless /^\| Text::Wrap is/; # start is ok +print "ok 1\n"; + +print "not " if /^.{31,}$/m; # no line longer than 30 chars +print "ok 2\n"; + +print "not " unless /^\|\w/m; # other lines start with +print "ok 3\n"; + +print "not " unless /\bsubsquent\b/; # look for a random word +print "ok 4\n"; + +print "not " unless /\bdevice\./; # look for last word +print "ok 5\n"; diff --git a/gnu/usr.bin/perl/t/lib/timelocal.t b/gnu/usr.bin/perl/t/lib/timelocal.t new file mode 100644 index 00000000000..adc1b1b0615 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/timelocal.t @@ -0,0 +1,87 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Time::Local; + +# Set up time values to test +@time = + ( + #year,mon,day,hour,min,sec + [1970, 1, 1, 00, 00, 00], + [1980, 2, 28, 12, 00, 00], + [1980, 2, 29, 12, 00, 00], + [1999, 12, 31, 23, 59, 59], + [2000, 1, 1, 00, 00, 00], + [2010, 10, 12, 14, 13, 12], + ); + +print "1..", @time * 2 + 5, "\n"; + +$count = 1; +for (@time) { + my($year, $mon, $mday, $hour, $min, $sec) = @$_; + $year -= 1900; + $mon --; + my $time = timelocal($sec,$min,$hour,$mday,$mon,$year); + # print scalar(localtime($time)), "\n"; + my($s,$m,$h,$D,$M,$Y) = localtime($time); + + if ($s == $sec && + $m == $min && + $h == $hour && + $D == $mday && + $M == $mon && + $Y == $year + ) { + print "ok $count\n"; + } else { + print "not ok $count\n"; + } + $count++; + + # Test gmtime function + $time = timegm($sec,$min,$hour,$mday,$mon,$year); + ($s,$m,$h,$D,$M,$Y) = gmtime($time); + + if ($s == $sec && + $m == $min && + $h == $hour && + $D == $mday && + $M == $mon && + $Y == $year + ) { + print "ok $count\n"; + } else { + print "not ok $count\n"; + } + $count++; +} + +#print "Testing that the differences between a few dates makes sence...\n"; + +timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90) == 3600 + or print "not "; +print "ok ", $count++, "\n"; + +timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99) == 24 * 3600 + or print "not "; +print "ok ", $count++, "\n"; + +# Diff beween Jan 1, 1970 and Mar 1, 1970 = (31 + 28 = 59 days) +timegm(0,0,0, 1, 2, 70) - timegm(0,0,0, 1, 0, 70) == 59 * 24 * 3600 + or print "not "; +print "ok ", $count++, "\n"; + + +#print "Testing timelocal.pl module too...\n"; +package test; +require 'timelocal.pl'; +timegm(0,0,0,1,0,70) == main::timegm(0,0,0,1,0,70) or print "not "; +print "ok ", $main::count++, "\n"; + +timelocal(1,2,3,4,5,78) == main::timelocal(1,2,3,4,5,78) or print "not "; +print "ok ", $main::count++, "\n"; diff --git a/gnu/usr.bin/perl/t/lib/trig.t b/gnu/usr.bin/perl/t/lib/trig.t new file mode 100644 index 00000000000..c2bc2a8b5bc --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/trig.t @@ -0,0 +1,57 @@ +#!./perl + +# +# Regression tests for the Math::Trig package +# +# The tests are quite modest as the Math::Complex tests exercise +# these quite vigorously. +# +# -- Jarkko Hietaniemi, April 1997 + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::Trig; + +use strict; + +use vars qw($x $y $z); + +my $eps = 1e-11; + +sub near ($$;$) { + abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps); +} + +print "1..7\n"; + +$x = 0.9; +print 'not ' unless (near(tan($x), sin($x) / cos($x))); +print "ok 1\n"; + +print 'not ' unless (near(sinh(2), 3.62686040784702)); +print "ok 2\n"; + +print 'not ' unless (near(acsch(0.1), 2.99822295029797)); +print "ok 3\n"; + +$x = asin(2); +print 'not ' unless (ref $x eq 'Math::Complex'); +print "ok 4\n"; + +# avoid using Math::Complex here +$x =~ /^([^-]+)(-[^i]+)i$/; +($y, $z) = ($1, $2); +print 'not ' unless (near($y, 1.5707963267949) and + near($z, -1.31695789692482)); +print "ok 5\n"; + +print 'not ' unless (near(deg2rad(90), pi/2)); +print "ok 6\n"; + +print 'not ' unless (near(rad2deg(pi), 180)); +print "ok 7\n"; + +# eof diff --git a/gnu/usr.bin/perl/t/op/arith.t b/gnu/usr.bin/perl/t/op/arith.t new file mode 100644 index 00000000000..43af807b8b4 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/arith.t @@ -0,0 +1,12 @@ +#!./perl + +print "1..4\n"; + +sub try ($$) { + print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; +} + +try 1, 13 % 4 == 1; +try 2, -13 % 4 == 3; +try 3, 13 % -4 == -3; +try 4, -13 % -4 == -1; diff --git a/gnu/usr.bin/perl/t/op/assignwarn.t b/gnu/usr.bin/perl/t/op/assignwarn.t new file mode 100644 index 00000000000..57e89c45e04 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/assignwarn.t @@ -0,0 +1,61 @@ +#!./perl + +# +# Verify which OP= operators warn if their targets are undefined. +# Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com> +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +$^W = 1; +my $warn = ""; +$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; + +sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } + +sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } + +print "1..23\n"; + +{ my $x; $x ++; ok 1, ! uninitialized; } +{ my $x; $x --; ok 2, ! uninitialized; } +{ my $x; ++ $x; ok 3, ! uninitialized; } +{ my $x; -- $x; ok 4, ! uninitialized; } + +{ my $x; $x **= 1; ok 5, uninitialized; } + +{ my $x; $x += 1; ok 6, ! uninitialized; } +{ my $x; $x -= 1; ok 7, ! uninitialized; } + +{ my $x; $x .= 1; ok 8, ! uninitialized; } + +{ my $x; $x *= 1; ok 9, uninitialized; } +{ my $x; $x /= 1; ok 10, uninitialized; } +{ my $x; $x %= 1; ok 11, uninitialized; } + +{ my $x; $x x= 1; ok 12, uninitialized; } + +{ my $x; $x &= 1; ok 13, uninitialized; } +{ my $x; $x |= 1; ok 14, ! uninitialized; } +{ my $x; $x ^= 1; ok 15, ! uninitialized; } + +{ my $x; $x &&= 1; ok 16, ! uninitialized; } +{ my $x; $x ||= 1; ok 17, ! uninitialized; } + +{ my $x; $x <<= 1; ok 18, uninitialized; } +{ my $x; $x >>= 1; ok 19, uninitialized; } + +{ my $x; $x &= "x"; ok 20, uninitialized; } +{ my $x; $x |= "x"; ok 21, ! uninitialized; } +{ my $x; $x ^= "x"; ok 22, ! uninitialized; } + +ok 23, $warn eq ''; + +# If we got any errors that we were not expecting, then print them +print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/gnu/usr.bin/perl/t/op/bop.t b/gnu/usr.bin/perl/t/op/bop.t new file mode 100644 index 00000000000..0c55029b931 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/bop.t @@ -0,0 +1,55 @@ +#!./perl + +# +# test the bit operators '&', '|', '^', '~', '<<', and '>>' +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..18\n"; + +# numerics +print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); +print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n"); +print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n"); +print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n"); + +# shifts +print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n"); +print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n"); + +# signed vs. unsigned +print ((~0 > 0 && do { use integer; ~0 } == -1) + ? "ok 7\n" : "not ok 7\n"); + +my $bits = 0; +for (my $i = ~0; $i; $i >>= 1) { ++$bits; } +my $cusp = 1 << ($bits - 1); + +print ((($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0) + ? "ok 8\n" : "not ok 8\n"); +print ((($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0) + ? "ok 9\n" : "not ok 9\n"); +print ((($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0) + ? "ok 10\n" : "not ok 10\n"); +print (((1 << ($bits - 1)) == $cusp && + do { use integer; 1 << ($bits - 1) } == -$cusp) + ? "ok 11\n" : "not ok 11\n"); +print ((($cusp >> 1) == ($cusp / 2) && + do { use integer; $cusp >> 1 } == -($cusp / 2)) + ? "ok 12\n" : "not ok 12\n"); + +# short strings +print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 13\n" : "not ok 13\n"); +print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 14\n" : "not ok 14\n"); +print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 15\n" : "not ok 15\n"); + +# long strings +$foo = "A" x 150; +$bar = "z" x 75; +print (($foo & $bar) eq ('@'x75 ) ? "ok 16\n" : "not ok 16\n"); +print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 17\n" : "not ok 17\n"); +print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 18\n" : "not ok 18\n"); diff --git a/gnu/usr.bin/perl/t/op/closure.t b/gnu/usr.bin/perl/t/op/closure.t new file mode 100644 index 00000000000..1220998b6b6 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/closure.t @@ -0,0 +1,454 @@ +#!./perl +# -*- Mode: Perl -*- +# closure.t: +# Original written by Ulrich Pfeifer on 2 Jan 1997. +# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + +print "1..167\n"; + +my $test = 1; +sub test (&) { + print ((&{$_[0]})?"ok $test\n":"not ok $test\n"); + $test++; +} + +my $i = 1; +sub foo { $i = shift if @_; $i } + +# no closure +test { foo == 1 }; +foo(2); +test { foo == 2 }; + +# closure: lexical outside sub +my $foo = sub {$i = shift if @_; $i }; +my $bar = sub {$i = shift if @_; $i }; +test {&$foo() == 2 }; +&$foo(3); +test {&$foo() == 3 }; +# did the lexical change? +test { foo == 3 and $i == 3}; +# did the second closure notice? +test {&$bar() == 3 }; + +# closure: lexical inside sub +sub bar { + my $i = shift; + sub { $i = shift if @_; $i } +} + +$foo = bar(4); +$bar = bar(5); +test {&$foo() == 4 }; +&$foo(6); +test {&$foo() == 6 }; +test {&$bar() == 5 }; + +# nested closures +sub bizz { + my $i = 7; + if (@_) { + my $i = shift; + sub {$i = shift if @_; $i }; + } else { + my $i = $i; + sub {$i = shift if @_; $i }; + } +} +$foo = bizz(); +$bar = bizz(); +test {&$foo() == 7 }; +&$foo(8); +test {&$foo() == 8 }; +test {&$bar() == 7 }; + +$foo = bizz(9); +$bar = bizz(10); +test {&$foo(11)-1 == &$bar()}; + +my @foo; +for (qw(0 1 2 3 4)) { + my $i = $_; + $foo[$_] = sub {$i = shift if @_; $i }; +} + +test { + &{$foo[0]}() == 0 and + &{$foo[1]}() == 1 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 3 and + &{$foo[4]}() == 4 + }; + +for (0 .. 4) { + &{$foo[$_]}(4-$_); +} + +test { + &{$foo[0]}() == 4 and + &{$foo[1]}() == 3 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 1 and + &{$foo[4]}() == 0 + }; + +sub barf { + my @foo; + for (qw(0 1 2 3 4)) { + my $i = $_; + $foo[$_] = sub {$i = shift if @_; $i }; + } + @foo; +} + +@foo = barf(); +test { + &{$foo[0]}() == 0 and + &{$foo[1]}() == 1 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 3 and + &{$foo[4]}() == 4 + }; + +for (0 .. 4) { + &{$foo[$_]}(4-$_); +} + +test { + &{$foo[0]}() == 4 and + &{$foo[1]}() == 3 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 1 and + &{$foo[4]}() == 0 + }; + +# Additional tests by Tom Phoenix <rootbeer@teleport.com>. + +{ + use strict; + + use vars qw!$test!; + my($debugging, %expected, $inner_type, $where_declared, $within); + my($nc_attempt, $call_outer, $call_inner, $undef_outer); + my($code, $inner_sub_test, $expected, $line, $errors, $output); + my(@inners, $sub_test, $pid); + $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; + + # The expected values for these tests + %expected = ( + 'global_scalar' => 1001, + 'global_array' => 2101, + 'global_hash' => 3004, + 'fs_scalar' => 4001, + 'fs_array' => 5101, + 'fs_hash' => 6004, + 'sub_scalar' => 7001, + 'sub_array' => 8101, + 'sub_hash' => 9004, + 'foreach' => 10011, + ); + + # Our innermost sub is either named or anonymous + for $inner_type (qw!named anon!) { + # And it may be declared at filescope, within a named + # sub, or within an anon sub + for $where_declared (qw!filescope in_named in_anon!) { + # And that, in turn, may be within a foreach loop, + # a naked block, or another named sub + for $within (qw!foreach naked other_sub!) { + + # Here are a number of variables which show what's + # going on, in a way. + $nc_attempt = 0+ # Named closure attempted + ( ($inner_type eq 'named') || + ($within eq 'other_sub') ) ; + $call_inner = 0+ # Need to call &inner + ( ($inner_type eq 'anon') && + ($within eq 'other_sub') ) ; + $call_outer = 0+ # Need to call &outer or &$outer + ( ($inner_type eq 'anon') && + ($within ne 'other_sub') ) ; + $undef_outer = 0+ # $outer is created but unused + ( ($where_declared eq 'in_anon') && + (not $call_outer) ) ; + + $code = "# This is a test script built by t/op/closure.t\n\n"; + + $code .= <<"DEBUG_INFO" if $debugging; +# inner_type: $inner_type +# where_declared: $where_declared +# within: $within +# nc_attempt: $nc_attempt +# call_inner: $call_inner +# call_outer: $call_outer +# undef_outer: $undef_outer +DEBUG_INFO + + $code .= <<"END_MARK_ONE"; + +BEGIN { \$SIG{__WARN__} = sub { + my \$msg = \$_[0]; +END_MARK_ONE + + $code .= <<"END_MARK_TWO" if $nc_attempt; + return if index(\$msg, 'will not stay shared') != -1; + return if index(\$msg, 'may be unavailable') != -1; +END_MARK_TWO + + $code .= <<"END_MARK_THREE"; # Backwhack a lot! + print "not ok: got unexpected warning \$msg\\n"; +} } + +{ + my \$test = $test; + sub test (&) { + my \$result = &{\$_[0]}; + print "not " unless \$result; + print "ok \$test\\n"; + \$test++; + } +} + +# some of the variables which the closure will access +\$global_scalar = 1000; +\@global_array = (2000, 2100, 2200, 2300); +%global_hash = 3000..3009; + +my \$fs_scalar = 4000; +my \@fs_array = (5000, 5100, 5200, 5300); +my %fs_hash = 6000..6009; + +END_MARK_THREE + + if ($where_declared eq 'filescope') { + # Nothing here + } elsif ($where_declared eq 'in_named') { + $code .= <<'END'; +sub outer { + my $sub_scalar = 7000; + my @sub_array = (8000, 8100, 8200, 8300); + my %sub_hash = 9000..9009; +END + # } + } elsif ($where_declared eq 'in_anon') { + $code .= <<'END'; +$outer = sub { + my $sub_scalar = 7000; + my @sub_array = (8000, 8100, 8200, 8300); + my %sub_hash = 9000..9009; +END + # } + } else { + die "What was $where_declared?" + } + + if ($within eq 'foreach') { + $code .= " + my \$foreach = 12000; + my \@list = (10000, 10010); + foreach \$foreach (\@list) { + " # } + } elsif ($within eq 'naked') { + $code .= " { # naked block\n" # } + } elsif ($within eq 'other_sub') { + $code .= " sub inner_sub {\n" # } + } else { + die "What was $within?" + } + + $sub_test = $test; + @inners = ( qw!global_scalar global_array global_hash! , + qw!fs_scalar fs_array fs_hash! ); + push @inners, 'foreach' if $within eq 'foreach'; + if ($where_declared ne 'filescope') { + push @inners, qw!sub_scalar sub_array sub_hash!; + } + for $inner_sub_test (@inners) { + + if ($inner_type eq 'named') { + $code .= " sub named_$sub_test " + } elsif ($inner_type eq 'anon') { + $code .= " \$anon_$sub_test = sub " + } else { + die "What was $inner_type?" + } + + # Now to write the body of the test sub + if ($inner_sub_test eq 'global_scalar') { + $code .= '{ ++$global_scalar }' + } elsif ($inner_sub_test eq 'fs_scalar') { + $code .= '{ ++$fs_scalar }' + } elsif ($inner_sub_test eq 'sub_scalar') { + $code .= '{ ++$sub_scalar }' + } elsif ($inner_sub_test eq 'global_array') { + $code .= '{ ++$global_array[1] }' + } elsif ($inner_sub_test eq 'fs_array') { + $code .= '{ ++$fs_array[1] }' + } elsif ($inner_sub_test eq 'sub_array') { + $code .= '{ ++$sub_array[1] }' + } elsif ($inner_sub_test eq 'global_hash') { + $code .= '{ ++$global_hash{3002} }' + } elsif ($inner_sub_test eq 'fs_hash') { + $code .= '{ ++$fs_hash{6002} }' + } elsif ($inner_sub_test eq 'sub_hash') { + $code .= '{ ++$sub_hash{9002} }' + } elsif ($inner_sub_test eq 'foreach') { + $code .= '{ ++$foreach }' + } else { + die "What was $inner_sub_test?" + } + + # Close up + if ($inner_type eq 'anon') { + $code .= ';' + } + $code .= "\n"; + $sub_test++; # sub name sequence number + + } # End of foreach $inner_sub_test + + # Close up $within block # { + $code .= " }\n\n"; + + # Close up $where_declared block + if ($where_declared eq 'in_named') { # { + $code .= "}\n\n"; + } elsif ($where_declared eq 'in_anon') { # { + $code .= "};\n\n"; + } + + # We may need to do something with the sub we just made... + $code .= "undef \$outer;\n" if $undef_outer; + $code .= "&inner_sub;\n" if $call_inner; + if ($call_outer) { + if ($where_declared eq 'in_named') { + $code .= "&outer;\n\n"; + } elsif ($where_declared eq 'in_anon') { + $code .= "&\$outer;\n\n" + } + } + + # Now, we can actually prep to run the tests. + for $inner_sub_test (@inners) { + $expected = $expected{$inner_sub_test} or + die "expected $inner_sub_test missing"; + + # Named closures won't access the expected vars + if ( $nc_attempt and + substr($inner_sub_test, 0, 4) eq "sub_" ) { + $expected = 1; + } + + # If you make a sub within a foreach loop, + # what happens if it tries to access the + # foreach index variable? If it's a named + # sub, it gets the var from "outside" the loop, + # but if it's anon, it gets the value to which + # the index variable is aliased. + # + # Of course, if the value was set only + # within another sub which was never called, + # the value has not been set yet. + # + if ($inner_sub_test eq 'foreach') { + if ($inner_type eq 'named') { + if ($call_outer || ($where_declared eq 'filescope')) { + $expected = 12001 + } else { + $expected = 1 + } + } + } + + # Here's the test: + if ($inner_type eq 'anon') { + $code .= "test { &\$anon_$test == $expected };\n" + } else { + $code .= "test { &named_$test == $expected };\n" + } + $test++; + } + + if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') { + # Fork off a new perl to run the tests. + # (This is so we can catch spurious warnings.) + $| = 1; print ""; $| = 0; # flush output before forking + pipe READ, WRITE or die "Can't make pipe: $!"; + pipe READ2, WRITE2 or die "Can't make second pipe: $!"; + die "Can't fork: $!" unless defined($pid = open PERL, "|-"); + unless ($pid) { + # Child process here. We're going to send errors back + # through the extra pipe. + close READ; + close READ2; + open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; + open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; + exec './perl', '-w', '-' + or die "Can't exec ./perl: $!"; + } else { + # Parent process here. + close WRITE; + close WRITE2; + print PERL $code; + close PERL; + { local $/; + $output = join '', <READ>; + $errors = join '', <READ2>; } + close READ; + close READ2; + } + } else { + # No fork(). Do it the hard way. + my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; + my $errfile = "terr$$"; $errfile++ while -e $errfile; + my @tmpfiles = ($cmdfile, $errfile); + open CMD, ">$cmdfile"; print CMD $code; close CMD; + my $cmd = (($^O eq 'VMS') ? "MCR $^X" + : ($^O eq 'MSWin32') ? '.\perl' + : './perl'); + $cmd .= " -w $cmdfile 2>$errfile"; + if ($^O eq 'VMS' or $^O eq 'MSWin32') { + # Use pipe instead of system so we don't inherit STD* from + # this process, and then foul our pipe back to parent by + # redirecting output in the child. + open PERL,"$cmd |" or die "Can't open pipe: $!\n"; + { local $/; $output = join '', <PERL> } + close PERL; + } else { + my $outfile = "tout$$"; $outfile++ while -e $outfile; + push @tmpfiles, $outfile; + system "$cmd >$outfile"; + { local $/; open IN, $outfile; $output = <IN>; close IN } + } + if ($?) { + printf "not ok: exited with error code %04X\n", $?; + $debugging or do { 1 while unlink @tmpfiles }; + exit; + } + { local $/; open IN, $errfile; $errors = <IN>; close IN } + 1 while unlink @tmpfiles; + } + print $output; + print STDERR $errors; + if ($debugging && ($errors || $? || ($output =~ /not ok/))) { + my $lnum = 0; + for $line (split '\n', $code) { + printf "%3d: %s\n", ++$lnum, $line; + } + } + printf "not ok: exited with error code %04X\n", $? if $?; + print "-" x 30, "\n" if $debugging; + + } # End of foreach $within + } # End of foreach $where_declared + } # End of foreach $inner_type + +} diff --git a/gnu/usr.bin/perl/t/op/cmp.t b/gnu/usr.bin/perl/t/op/cmp.t new file mode 100644 index 00000000000..4a7e68d4487 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/cmp.t @@ -0,0 +1,35 @@ +#!./perl + +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); + +$expect = ($#FOO+2) * ($#FOO+1); +print "1..$expect\n"; + +my $ok = 0; +for my $i (0..$#FOO) { + for my $j ($i..$#FOO) { + $ok++; + my $cmp = $FOO[$i] <=> $FOO[$j]; + if (!defined($cmp) || + $cmp == -1 && $FOO[$i] < $FOO[$j] || + $cmp == 0 && $FOO[$i] == $FOO[$j] || + $cmp == 1 && $FOO[$i] > $FOO[$j]) + { + print "ok $ok\n"; + } + else { + print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; + } + $ok++; + $cmp = $FOO[$i] cmp $FOO[$j]; + if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || + $cmp == 0 && $FOO[$i] eq $FOO[$j] || + $cmp == 1 && $FOO[$i] gt $FOO[$j]) + { + print "ok $ok\n"; + } + else { + print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; + } + } +} diff --git a/gnu/usr.bin/perl/t/op/gv.t b/gnu/usr.bin/perl/t/op/gv.t new file mode 100644 index 00000000000..ece32d936cd --- /dev/null +++ b/gnu/usr.bin/perl/t/op/gv.t @@ -0,0 +1,59 @@ +#!./perl + +# +# various typeglob tests +# + +print "1..11\n"; + +# type coersion on assignment +$foo = 'foo'; +$bar = *main::foo; +$bar = $foo; +print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n"; +$foo = *main::bar; + +# type coersion (not) on misc ops + +if ($foo) { + print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n"; +} + +unless ($foo =~ /abcd/) { + print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n"; +} + +if ($foo eq '*main::bar') { + print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n"; +} + +# type coersion on substitutions that match +$a = *main::foo; +$b = $a; +$a =~ s/^X//; +print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n"; +$a =~ s/^\*//; +print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n"; +print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n"; + +# typeglobs as lvalues +substr($foo, 0, 1) = "XXX"; +print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n"; +print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n"; + +# returning glob values +sub foo { + local($bar) = *main::foo; + $foo = *main::bar; + return ($foo, $bar); +} + +($fuu, $baa) = foo(); +if (defined $fuu) { + print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n"; +} + +if (defined $baa) { + print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n"; +} + diff --git a/gnu/usr.bin/perl/t/op/inc.t b/gnu/usr.bin/perl/t/op/inc.t new file mode 100644 index 00000000000..e5a2a921b3f --- /dev/null +++ b/gnu/usr.bin/perl/t/op/inc.t @@ -0,0 +1,52 @@ +#!./perl + + +# $RCSfile$ + +print "1..6\n"; + +# Verify that addition/subtraction properly upgrade to doubles. +# These tests are only significant on machines with 32 bit longs, +# and two's complement negation, but shouldn't fail anywhere. + +$a = 2147483647; +$c=$a++; +if ($a == 2147483648) + {print "ok 1\n"} +else + {print "not ok 1\n";} + +$a = 2147483647; +$c=++$a; +if ($a == 2147483648) + {print "ok 2\n"} +else + {print "not ok 2\n";} + +$a = 2147483647; +$a=$a+1; +if ($a == 2147483648) + {print "ok 3\n"} +else + {print "not ok 3\n";} + +$a = -2147483648; +$c=$a--; +if ($a == -2147483649) + {print "ok 4\n"} +else + {print "not ok 4\n";} + +$a = -2147483648; +$c=--$a; +if ($a == -2147483649) + {print "ok 5\n"} +else + {print "not ok 5\n";} + +$a = -2147483648; +$a=$a-1; +if ($a == -2147483649) + {print "ok 6\n"} +else + {print "not ok 6\n";} diff --git a/gnu/usr.bin/perl/t/op/method.t b/gnu/usr.bin/perl/t/op/method.t new file mode 100644 index 00000000000..d955705d1a1 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/method.t @@ -0,0 +1,122 @@ +#!./perl + +# +# test method calls and autoloading. +# + +print "1..24\n"; + +@A::ISA = 'B'; +@B::ISA = 'C'; + +sub C::d {"C::d"} +sub D::d {"D::d"} + +my $cnt = 0; +sub test { + print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; + # print "not " unless shift eq shift; + print "ok ", ++$cnt, "\n" +} + +test( A->d, "C::d"); # Update hash table; + +*B::d = \&D::d; # Import now. +test (A->d, "D::d"); # Update hash table; + +{ + local @A::ISA = qw(C); # Update hash table with split() assignment + test (A->d, "C::d"); + $#A::ISA = -1; + test (eval { A->d } || "fail", "fail"); +} +test (A->d, "D::d"); + +{ + local *B::d; + eval 'sub B::d {"B::d1"}'; # Import now. + test (A->d, "B::d1"); # Update hash table; + undef &B::d; + test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); +} + +test (A->d, "D::d"); # Back to previous state + +eval 'sub B::d {"B::d2"}'; # Import now. +test (A->d, "B::d2"); # Update hash table; + +# What follows is hardly guarantied to work, since the names in scripts +# are already linked to "pruned" globs. Say, `undef &B::d' if it were +# after `delete $B::{d}; sub B::d {}' would reach an old subroutine. + +undef &B::d; +delete $B::{d}; +test (A->d, "C::d"); # Update hash table; + +eval 'sub B::d {"B::d3"}'; # Import now. +test (A->d, "B::d3"); # Update hash table; + +delete $B::{d}; +*dummy::dummy = sub {}; # Mark as updated +test (A->d, "C::d"); + +eval 'sub B::d {"B::d4"}'; # Import now. +test (A->d, "B::d4"); # Update hash table; + +delete $B::{d}; # Should work without any help too +test (A->d, "C::d"); + +*A::x = *A::d; # See if cache incorrectly follows synonyms +A->d; +test (eval { A->x } || "nope", "nope"); + +eval <<'EOF'; +sub C::e; +BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg +sub Y::f; +$counter = 0; + +@X::ISA = 'Y'; +@Y::ISA = 'B'; + +sub B::AUTOLOAD { + my $c = ++$counter; + my $method = $B::AUTOLOAD; + my $msg = "B: In $method, $c"; + eval "sub $method { \$msg }"; + goto &$method; +} +sub C::AUTOLOAD { + my $c = ++$counter; + my $method = $C::AUTOLOAD; + my $msg = "C: In $method, $c"; + eval "sub $method { \$msg }"; + goto &$method; +} +EOF + +test(A->e(), "C: In C::e, 1"); # We get a correct autoload +test(A->e(), "C: In C::e, 1"); # Which sticks + +test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top +test(A->ee(), "B: In A::ee, 2"); # Which sticks + +test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method +test(Y->f(), "B: In Y::f, 3"); # Which sticks + +# This test is not intended to be reasonable. It is here just to let you +# know that you broke some old construction. Feel free to rewrite the test +# if your patch breaks it. + +*B::AUTOLOAD = sub { + my $c = ++$counter; + my $method = $AUTOLOAD; + *$AUTOLOAD = sub { "new B: In $method, $c" }; + goto &$AUTOLOAD; +}; + +test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload +test(A->eee(), "new B: In A::eee, 4"); # Which sticks + +# this test added due to bug discovery +test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); diff --git a/gnu/usr.bin/perl/t/op/recurse.t b/gnu/usr.bin/perl/t/op/recurse.t new file mode 100644 index 00000000000..6594940a903 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/recurse.t @@ -0,0 +1,86 @@ +#!./perl + +# +# test recursive functions. +# + +print "1..23\n"; + +sub gcd ($$) { + return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); + return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]); + $_[0]; +} + +sub factorial ($) { + $_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1); +} + +sub fibonacci ($) { + $_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1); +} + +# Highly recursive, highly aggressive. +# Kids, don't try this at home. +# +# For example ackermann(4,1) will take quite a long time. +# It will simply eat away your memory. Trust me. + +sub ackermann ($$) { + return $_[1] + 1 if ($_[0] == 0); + return ackermann($_[0] - 1, 1) if ($_[1] == 0); + ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1)); +} + +# Highly recursive, highly boring. + +sub takeuchi ($$$) { + $_[1] < $_[0] ? + takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]), + takeuchi($_[1] - 1, $_[2], $_[0]), + takeuchi($_[2] - 1, $_[0], $_[1])) + : $_[2]; +} + +print 'not ' unless (($d = gcd(1147, 1271)) == 31); +print "ok 1\n"; +print "# gcd(1147, 1271) = $d\n"; + +print 'not ' unless (($d = gcd(1908, 2016)) == 36); +print "ok 2\n"; +print "# gcd(1908, 2016) = $d\n"; + +print 'not ' unless (($f = factorial(10)) == 3628800); +print "ok 3\n"; +print "# factorial(10) = $f\n"; + +print 'not ' unless (($f = factorial(factorial(3))) == 720); +print "ok 4\n"; +print "# factorial(factorial(3)) = $f\n"; + +print 'not ' unless (($f = fibonacci(10)) == 89); +print "ok 5\n"; +print "# fibonacci(10) = $f\n"; + +print 'not ' unless (($f = fibonacci(fibonacci(7))) == 17711); +print "ok 6\n"; +print "# fibonacci(fibonacci(7)) = $f\n"; + +$i = 7; + +@ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61); + +for $x (0..3) { + for $y (0..3) { + $a = ackermann($x, $y); + print 'not ' unless ($a == shift(@ack)); + print "ok ", $i++, "\n"; + print "# ackermann($x, $y) = $a\n"; + } +} + +($x, $y, $z) = (18, 12, 6); + +print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); +print "ok ", $i++, "\n"; +print "# takeuchi($x, $y, $z) = $t\n"; diff --git a/gnu/usr.bin/perl/t/op/runlevel.t b/gnu/usr.bin/perl/t/op/runlevel.t new file mode 100644 index 00000000000..6693a829a88 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/runlevel.t @@ -0,0 +1,317 @@ +#!./perl + +## +## all of these tests are from Michael Schroeder +## <Michael.Schroeder@informatik.uni-erlangen.de> +## +## The more esoteric failure modes require Michael's +## stack-of-stacks patch (so we don't test them here, +## and they are commented out before the __END__). +## +## The remaining tests pass with a simpler fix +## intended for 5.004 +## +## Gurusamy Sarathy <gsar@umich.edu> 97-02-24 +## + +chdir 't' if -d 't'; +@INC = "../lib"; +$Is_VMS = $^O eq 'VMS'; +$Is_MSWin32 = $^O eq 'MSWin32'; +$ENV{PERL5LIB} = "../lib" unless $Is_VMS; + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "runltmp000"; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile; } } + +for (@prgs){ + my $switch; + if (s/^\s*(-\w+)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, ">$tmpfile"; + print TEST "$prog\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X "-I[-.lib]" $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/runltmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + if ($results ne $expected) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +=head2 stay out of here (the real tests are after __END__) + +## +## these tests don't pass yet (need the full stack-of-stacks patch) +## GSAR 97-02-24 +## + +######## +# sort within sort +sub sortfn { + (split(/./, 'x'x10000))[0]; + my (@y) = ( 4, 6, 5); + @y = sort { $a <=> $b } @y; + print "sortfn ".join(', ', @y)."\n"; + return $_[0] <=> $_[1]; +} +@x = ( 3, 2, 1 ); +@x = sort { &sortfn($a, $b) } @x; +print "---- ".join(', ', @x)."\n"; +EXPECT +sortfn 4, 5, 6 +---- 1, 2, 3 +######## +# trapping eval within sort (doesn't work currently because +# die does a SWITCHSTACK()) +@a = (3, 2, 1); +@a = sort { eval('die("no way")') , $a <=> $b} @a; +print join(", ", @a)."\n"; +EXPECT +1, 2, 3 +######## +# this actually works fine, but results in a poor error message +@a = (1, 2, 3); +foo: +{ + @a = sort { last foo; } @a; +} +EXPECT +cannot reach destination block at - line 2. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + next; + return "ZZZ"; +} +sub STORE { +} + +package main; + +tie $bar, TEST; +{ + print "- $bar\n"; +} +print "OK\n"; +EXPECT +cannot reach destination block at - line 8. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + goto bbb; + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +exit; +bbb: +print "bbb\n"; +EXPECT +bbb +######## +# trapping eval within sort (doesn't work currently because +# die does a SWITCHSTACK()) +sub foo { + $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +package TEST; +sub TIESCALAR { + my $foo; + next; + return bless \$foo; +} +package main; +{ +tie $bar, TEST; +} +EXPECT +cannot reach destination block at - line 4. +######## +# large stack extension causes realloc, and segfault +package TEST; +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + return "fetch"; +} +sub STORE { +(split(/./, 'x'x10000))[0]; +} +package main; +tie $bar, TEST; +$bar = "x"; + +=cut + +## +## +## The real tests begin here +## +## + +__END__ +@a = (1, 2, 3); +{ + @a = sort { last ; } @a; +} +EXPECT +Can't "last" outside a block at - line 3. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + eval 'die("test")'; + print "still in fetch\n"; + return ">$@<"; +} +package main; + +tie $bar, TEST; +print "- $bar\n"; +EXPECT +still in fetch +- >test at (eval 1) line 1. +< +######## +package TEST; + +sub TIESCALAR { + my $foo; + eval('die("foo\n")'); + print "after eval\n"; + return bless \$foo; +} +sub FETCH { + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +print "OK\n"; +EXPECT +after eval +- ZZZ +OK +######## +package TEST; + +sub TIEHANDLE { + my $foo; + return bless \$foo; +} +sub PRINT { +print STDERR "PRINT CALLED\n"; +(split(/./, 'x'x10000))[0]; +eval('die("test\n")'); +} + +package main; + +open FH, ">&STDOUT"; +tie *FH, TEST; +print FH "OK\n"; +print STDERR "DONE\n"; +EXPECT +PRINT CALLED +DONE +######## +sub warnhook { + print "WARNHOOK\n"; + eval('die("foooo\n")'); +} +$SIG{'__WARN__'} = 'warnhook'; +warn("dfsds\n"); +print "END\n"; +EXPECT +WARNHOOK +END +######## +package TEST; + +use overload + "\"\"" => \&str +; + +sub str { + eval('die("test\n")'); + return "STR"; +} + +package main; + +$bar = bless {}, TEST; +print "$bar\n"; +print "OK\n"; +EXPECT +STR +OK +######## +sub foo { + $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +sub foo { + goto bar if $a == 0 || $b == 0; + $a <=> $b; +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +exit; +bar: +print "bar reached\n"; +EXPECT +Can't "goto" outside a block at - line 2. diff --git a/gnu/usr.bin/perl/t/op/sysio.t b/gnu/usr.bin/perl/t/op/sysio.t new file mode 100644 index 00000000000..0af333db848 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/sysio.t @@ -0,0 +1,194 @@ +#!./perl + +print "1..36\n"; + +chdir('op') || die "sysio.t: cannot look for myself: $!"; + +open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; + +$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32'); + +$x = 'abc'; + +# should not be able to do negative lengths +eval { sysread(I, $x, -1) }; +print 'not ' unless ($@ =~ /^Negative length /); +print "ok 1\n"; + +# $x should be intact +print 'not ' unless ($x eq 'abc'); +print "ok 2\n"; + +# should not be able to read before the buffer +eval { sysread(I, $x, 1, -4) }; +print 'not ' unless ($x eq 'abc'); +print "ok 3\n"; + +# $x should be intact +print 'not ' unless ($x eq 'abc'); +print "ok 4\n"; + +$a ='0123456789'; + +# default offset 0 +print 'not ' unless(sysread(I, $a, 3) == 3); +print "ok 5\n"; + +# $a should be as follows +print 'not ' unless ($a eq '#!.'); +print "ok 6\n"; + +# reading past the buffer should zero pad +print 'not ' unless(sysread(I, $a, 2, 5) == 2); +print "ok 7\n"; + +# the zero pad should be seen now +print 'not ' unless ($a eq "#!.\0\0/p"); +print "ok 8\n"; + +# try changing the last two characters of $a +print 'not ' unless(sysread(I, $a, 3, -2) == 3); +print "ok 9\n"; + +# the last two characters of $a should have changed (into three) +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 10\n"; + +$outfile = 'sysio.out'; + +open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; + +select(O); $|=1; select(STDOUT); + +# cannot write negative lengths +eval { syswrite(O, $x, -1) }; +print 'not ' unless ($@ =~ /^Negative length /); +print "ok 11\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 12\n"; + +# $outfile still intact +print 'not ' if (-s $outfile); +print "ok 13\n"; + +# should not be able to write from after the buffer +eval { syswrite(O, $x, 1, 3) }; +print 'not ' unless ($@ =~ /^Offset outside string /); +print "ok 14\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 15\n"; + +# $outfile still intact +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' if (-s $outfile); +print "ok 16\n"; + +# should not be able to write from before the buffer + +eval { syswrite(O, $x, 1, -4) }; +print 'not ' unless ($@ =~ /^Offset outside string /); +print "ok 17\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 18\n"; + +# $outfile still intact +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' if (-s $outfile); +print "ok 19\n"; + +# default offset 0 +print 'not ' unless (syswrite(O, $a, 2) == 2); +print "ok 20\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 21\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 2); +print "ok 22\n"; + +# with offset +print 'not ' unless (syswrite(O, $a, 2, 5) == 2); +print "ok 23\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 24\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 4); +print "ok 25\n"; + +# with negative offset and a bit too much length +print 'not ' unless (syswrite(O, $a, 5, -3) == 3); +print "ok 26\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 27\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 7); +print "ok 28\n"; + +close(O); + +open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; + +$b = 'xyz'; + +# reading too much only return as much as available +print 'not ' unless (sysread(I, $b, 100) == 7); +print "ok 29\n"; +# this we should have +print 'not ' unless ($b eq '#!ererl'); +print "ok 30\n"; + +# test sysseek + +print 'not ' unless sysseek(I, 2, 0) == 2; +print "ok 31\n"; +sysread(I, $b, 3); +print 'not ' unless $b eq 'ere'; +print "ok 32\n"; + +print 'not ' unless sysseek(I, -2, 1) == 3; +print "ok 33\n"; +sysread(I, $b, 4); +print 'not ' unless $b eq 'rerl'; +print "ok 34\n"; + +print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; +print "ok 35\n"; +print 'not ' if defined sysseek(I, -1, 1); +print "ok 36\n"; + +close(I); + +unlink $outfile; + +chdir('..'); + +1; + +# eof diff --git a/gnu/usr.bin/perl/t/op/taint.t b/gnu/usr.bin/perl/t/op/taint.t new file mode 100644 index 00000000000..8437c43c453 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/taint.t @@ -0,0 +1,574 @@ +#!./perl -T +# +# Taint tests by Tom Phoenix <rootbeer@teleport.com>. +# +# I don't claim to know all about tainting. If anyone sees +# tests that I've missed here, please add them. But this is +# better than having no tests at all, right? +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +use strict; +use Config; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : + $Is_MSWin32 ? '.\perl' : './perl'; +my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; + +if ($Is_VMS) { + my (%old, $x); + for $x ('DCL$PATH', @MoreEnv) { + ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; + } + eval <<EndOfCleanup; + END { + \$ENV{PATH} = ''; + warn "# Note: logical name 'PATH' may have been deleted\n"; + @ENV{keys %old} = values %old; + } +EndOfCleanup +} + +# Sources of taint: +# The empty tainted value, for tainting strings +my $TAINT = substr($^X, 0, 0); +# A tainted zero, useful for tainting numbers +my $TAINT0 = 0 + $TAINT; + +# This taints each argument passed. All must be lvalues. +# Side effect: It also stringifies them. :-( +sub taint_these (@) { + for (@_) { $_ .= $TAINT } +} + +# How to identify taint when you see it +sub any_tainted (@) { + not eval { join("",@_), kill 0; 1 }; +} +sub tainted ($) { + any_tainted @_; +} +sub all_tainted (@) { + for (@_) { return 0 unless tainted $_ } + 1; +} + +sub test ($$;$) { + my($serial, $boolean, $diag) = @_; + if ($boolean) { + print "ok $serial\n"; + } else { + print "not ok $serial\n"; + for (split m/^/m, $diag) { + print "# $_"; + } + print "\n" unless + $diag eq '' + or substr($diag, -1) eq "\n"; + } +} + +# We need an external program to call. +my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$"); +END { unlink $ECHO } +open PROG, "> $ECHO" or die "Can't create $ECHO: $!"; +print PROG 'print "@ARGV\n"', "\n"; +close PROG; +my $echo = "$Invoke_Perl $ECHO"; + +print "1..140\n"; + +# First, let's make sure that Perl is checking the dangerous +# environment variables. Maybe they aren't set yet, so we'll +# taint them ourselves. +{ + $ENV{'DCL$PATH'} = '' if $Is_VMS; + + $ENV{PATH} = ''; + delete @ENV{@MoreEnv}; + $ENV{TERM} = 'dumb'; + + test 1, eval { `$echo 1` } eq "1\n"; + + if ($Is_MSWin32 || $Is_VMS) { + print "# Environment tainting tests skipped\n"; + for (2..5) { print "ok $_\n" } + } + else { + my @vars = ('PATH', @MoreEnv); + while (my $v = $vars[0]) { + local $ENV{$v} = $TAINT; + last if eval { `$echo 1` }; + last unless $@ =~ /^Insecure \$ENV{$v}/; + shift @vars; + } + test 2, !@vars, "\$$vars[0]"; + + # tainted $TERM is unsafe only if it contains metachars + local $ENV{TERM}; + $ENV{TERM} = 'e=mc2'; + test 3, eval { `$echo 1` } eq "1\n"; + $ENV{TERM} = 'e=mc2' . $TAINT; + test 4, eval { `$echo 1` } eq ''; + test 5, $@ =~ /^Insecure \$ENV{TERM}/, $@; + } + + my $tmp; + if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32) { + print "# all directories are writeable\n"; + } + else { + $tmp = (grep { defined and -d and (stat _)[2] & 2 } + qw(/tmp /var/tmp /usr/tmp /sys$scratch), + @ENV{qw(TMP TEMP)})[0] + or print "# can't find world-writeable directory to test PATH\n"; + } + + if ($tmp) { + local $ENV{PATH} = $tmp; + test 6, eval { `$echo 1` } eq ''; + test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; + } + else { + for (6..7) { print "ok $_\n" } + } + + if ($Is_VMS) { + $ENV{'DCL$PATH'} = $TAINT; + test 8, eval { `$echo 1` } eq ''; + test 9, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; + if ($tmp) { + $ENV{'DCL$PATH'} = $tmp; + test 10, eval { `$echo 1` } eq ''; + test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; + } + else { + print "# can't find world-writeable directory to test DCL\$PATH\n"; + for (10..11) { print "ok $_\n" } + } + $ENV{'DCL$PATH'} = ''; + } + else { + print "# This is not VMS\n"; + for (8..11) { print "ok $_\n"; } + } +} + +# Let's see that we can taint and untaint as needed. +{ + my $foo = $TAINT; + test 12, tainted $foo; + + # That was a sanity check. If it failed, stop the insanity! + die "Taint checks don't seem to be enabled" unless tainted $foo; + + $foo = "foo"; + test 13, not tainted $foo; + + taint_these($foo); + test 14, tainted $foo; + + my @list = 1..10; + test 15, not any_tainted @list; + taint_these @list[1,3,5,7,9]; + test 16, any_tainted @list; + test 17, all_tainted @list[1,3,5,7,9]; + test 18, not any_tainted @list[0,2,4,6,8]; + + ($foo) = $foo =~ /(.+)/; + test 19, not tainted $foo; + + $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; + test 20, not tainted $foo; + test 21, $foo eq 'bar'; + + my $pi = 4 * atan2(1,1) + $TAINT0; + test 22, tainted $pi; + + ($pi) = $pi =~ /(\d+\.\d+)/; + test 23, not tainted $pi; + test 24, sprintf("%.5f", $pi) eq '3.14159'; +} + +# How about command-line arguments? The problem is that we don't +# always get some, so we'll run another process with some. +{ + my $arg = "./arg$$"; + open PROG, "> $arg" or die "Can't create $arg: $!"; + print PROG q{ + eval { join('', @ARGV), kill 0 }; + exit 0 if $@ =~ /^Insecure dependency/; + print "# Oops: \$@ was [$@]\n"; + exit 1; + }; + close PROG; + print `$Invoke_Perl "-T" $arg and some suspect arguments`; + test 25, !$?, "Exited with status $?"; + unlink $arg; +} + +# Reading from a file should be tainted +{ + my $file = './TEST'; + test 26, open(FILE, $file), "Couldn't open '$file': $!"; + + my $block; + sysread(FILE, $block, 100); + my $line = <FILE>; + close FILE; + test 27, tainted $block; + test 28, tainted $line; +} + +# Globs should be forbidden, except under VMS, +# which doesn't spawn an external program. +if ($Is_VMS) { + for (29..30) { print "ok $_\n"; } +} +else { + my @globs = eval { <*> }; + test 29, @globs == 0 && $@ =~ /^Insecure dependency/; + + @globs = eval { glob '*' }; + test 30, @globs == 0 && $@ =~ /^Insecure dependency/; +} + +# Output of commands should be tainted +{ + my $foo = `$echo abc`; + test 31, tainted $foo; +} + +# Certain system variables should be tainted +{ + test 32, all_tainted $^X, $0; +} + +# Results of matching should all be untainted +{ + my $foo = "abcdefghi" . $TAINT; + test 33, tainted $foo; + + $foo =~ /def/; + test 34, not any_tainted $`, $&, $'; + + $foo =~ /(...)(...)(...)/; + test 35, not any_tainted $1, $2, $3, $+; + + my @bar = $foo =~ /(...)(...)(...)/; + test 36, not any_tainted @bar; + + test 37, tainted $foo; # $foo should still be tainted! + test 38, $foo eq "abcdefghi"; +} + +# Operations which affect files can't use tainted data. +{ + test 39, eval { chmod 0, $TAINT } eq '', 'chmod'; + test 40, $@ =~ /^Insecure dependency/, $@; + + # There is no feature test in $Config{} for truncate, + # so we allow for the possibility that it's missing. + test 41, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; + test 42, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; + + test 43, eval { rename '', $TAINT } eq '', 'rename'; + test 44, $@ =~ /^Insecure dependency/, $@; + + test 45, eval { unlink $TAINT } eq '', 'unlink'; + test 46, $@ =~ /^Insecure dependency/, $@; + + test 47, eval { utime $TAINT } eq '', 'utime'; + test 48, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_chown}) { + test 49, eval { chown -1, -1, $TAINT } eq '', 'chown'; + test 50, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# chown() is not available\n"; + for (49..50) { print "ok $_\n" } + } + + if ($Config{d_link}) { + test 51, eval { link $TAINT, '' } eq '', 'link'; + test 52, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# link() is not available\n"; + for (51..52) { print "ok $_\n" } + } + + if ($Config{d_symlink}) { + test 53, eval { symlink $TAINT, '' } eq '', 'symlink'; + test 54, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# symlink() is not available\n"; + for (53..54) { print "ok $_\n" } + } +} + +# Operations which affect directories can't use tainted data. +{ + test 55, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; + test 56, $@ =~ /^Insecure dependency/, $@; + + test 57, eval { rmdir $TAINT } eq '', 'rmdir'; + test 58, $@ =~ /^Insecure dependency/, $@; + + test 59, eval { chdir $TAINT } eq '', 'chdir'; + test 60, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_chroot}) { + test 61, eval { chroot $TAINT } eq '', 'chroot'; + test 62, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# chroot() is not available\n"; + for (61..62) { print "ok $_\n" } + } +} + +# Some operations using files can't use tainted data. +{ + my $foo = "imaginary library" . $TAINT; + test 63, eval { require $foo } eq '', 'require'; + test 64, $@ =~ /^Insecure dependency/, $@; + + my $filename = "./taintB$$"; # NB: $filename isn't tainted! + END { unlink $filename if defined $filename } + $foo = $filename . $TAINT; + unlink $filename; # in any case + + test 65, eval { open FOO, $foo } eq '', 'open for read'; + test 66, $@ eq '', $@; # NB: This should be allowed + test 67, $! == 2; # File not found + + test 68, eval { open FOO, "> $foo" } eq '', 'open for write'; + test 69, $@ =~ /^Insecure dependency/, $@; +} + +# Commands to the system can't use tainted data +{ + my $foo = $TAINT; + + if ($^O eq 'amigaos') { + print "# open(\"|\") is not available\n"; + for (70..73) { print "ok $_\n" } + } + else { + test 70, eval { open FOO, "| $foo" } eq '', 'popen to'; + test 71, $@ =~ /^Insecure dependency/, $@; + + test 72, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 73, $@ =~ /^Insecure dependency/, $@; + } + + test 74, eval { exec $TAINT } eq '', 'exec'; + test 75, $@ =~ /^Insecure dependency/, $@; + + test 76, eval { system $TAINT } eq '', 'system'; + test 77, $@ =~ /^Insecure dependency/, $@; + + $foo = "*"; + taint_these $foo; + + test 78, eval { `$echo 1$foo` } eq '', 'backticks'; + test 79, $@ =~ /^Insecure dependency/, $@; + + if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe + test 80, join('', eval { glob $foo } ) ne '', 'globbing'; + test 81, $@ eq '', $@; + } + else { + for (80..81) { print "ok $_\n"; } + } +} + +# Operations which affect processes can't use tainted data. +{ + test 82, eval { kill 0, $TAINT } eq '', 'kill'; + test 83, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_setpgrp}) { + test 84, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; + test 85, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# setpgrp() is not available\n"; + for (84..85) { print "ok $_\n" } + } + + if ($Config{d_setprior}) { + test 86, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; + test 87, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# setpriority() is not available\n"; + for (86..87) { print "ok $_\n" } + } +} + +# Some miscellaneous operations can't use tainted data. +{ + if ($Config{d_syscall}) { + test 88, eval { syscall $TAINT } eq '', 'syscall'; + test 89, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# syscall() is not available\n"; + for (88..89) { print "ok $_\n" } + } + + { + my $foo = "x" x 979; + taint_these $foo; + local *FOO; + my $temp = "./taintC$$"; + END { unlink $temp } + test 90, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; + + test 91, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; + test 92, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_fcntl}) { + test 93, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; + test 94, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# fcntl() is not available\n"; + for (93..94) { print "ok $_\n" } + } + + close FOO; + } +} + +# Some tests involving references +{ + my $foo = 'abc' . $TAINT; + my $fooref = \$foo; + test 95, not tainted $fooref; + test 96, tainted $$fooref; + test 97, tainted $foo; +} + +# Some tests involving assignment +{ + my $foo = $TAINT0; + my $bar = $foo; + test 98, all_tainted $foo, $bar; + test 99, tainted($foo = $bar); + test 100, tainted($bar = $bar); + test 101, tainted($bar += $bar); + test 102, tainted($bar -= $bar); + test 103, tainted($bar *= $bar); + test 104, tainted($bar++); + test 105, tainted($bar /= $bar); + test 106, tainted($bar += 0); + test 107, tainted($bar -= 2); + test 108, tainted($bar *= -1); + test 109, tainted($bar /= 1); + test 110, tainted($bar--); + test 111, $bar == 0; +} + +# Test assignment and return of lists +{ + my @foo = ("A", "tainted" . $TAINT, "B"); + test 112, not tainted $foo[0]; + test 113, tainted $foo[1]; + test 114, not tainted $foo[2]; + my @bar = @foo; + test 115, not tainted $bar[0]; + test 116, tainted $bar[1]; + test 117, not tainted $bar[2]; + my @baz = eval { "A", "tainted" . $TAINT, "B" }; + test 118, not tainted $baz[0]; + test 119, tainted $baz[1]; + test 120, not tainted $baz[2]; + my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; + test 121, not tainted $plugh[0]; + test 122, tainted $plugh[1]; + test 123, not tainted $plugh[2]; + my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; + test 124, not tainted ((&$nautilus)[0]); + test 125, tainted ((&$nautilus)[1]); + test 126, not tainted ((&$nautilus)[2]); + my @xyzzy = &$nautilus; + test 127, not tainted $xyzzy[0]; + test 128, tainted $xyzzy[1]; + test 129, not tainted $xyzzy[2]; + my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; + test 130, not tainted ((&$red_october)[0]); + test 131, tainted ((&$red_october)[1]); + test 132, not tainted ((&$red_october)[2]); + my @corge = &$red_october; + test 133, not tainted $corge[0]; + test 134, tainted $corge[1]; + test 135, not tainted $corge[2]; +} + +# Test for system/library calls returning string data of dubious origin. +{ + # No reliable %Config check for getpw* + if (eval { setpwent(); getpwent(); 1 }) { + setpwent(); + my @getpwent = getpwent(); + die "getpwent: $!\n" unless (@getpwent); + test 136,( not tainted $getpwent[0] + and not tainted $getpwent[1] + and not tainted $getpwent[2] + and not tainted $getpwent[3] + and not tainted $getpwent[4] + and not tainted $getpwent[5] + and tainted $getpwent[6] # gecos + and not tainted $getpwent[7] + and not tainted $getpwent[8]); + endpwent(); + } else { + print "# getpwent() is not available\n"; + print "ok 136\n"; + } + + if ($Config{d_readdir}) { # pretty hard to imagine not + local(*D); + opendir(D, "op") or die "opendir: $!\n"; + my $readdir = readdir(D); + test 137, tainted $readdir; + closedir(OP); + } else { + print "# readdir() is not available\n"; + print "ok 137\n"; + } + + if ($Config{d_readlink} && $Config{d_symlink}) { + my $symlink = "sl$$"; + unlink($symlink); + symlink("/something/naughty", $symlink) or die "symlink: $!\n"; + my $readlink = readlink($symlink); + test 138, tainted $readlink; + unlink($symlink); + } else { + print "# readlink() or symlink() is not available\n"; + print "ok 138\n"; + } +} + +# test bitwise ops (regression bug) +{ + my $why = "y"; + my $j = "x" | $why; + test 139, not tainted $j; + $why = $TAINT."y"; + $j = "x" | $why; + test 140, tainted $j; +} + diff --git a/gnu/usr.bin/perl/t/op/tie.t b/gnu/usr.bin/perl/t/op/tie.t new file mode 100644 index 00000000000..77e74db4e2c --- /dev/null +++ b/gnu/usr.bin/perl/t/op/tie.t @@ -0,0 +1,155 @@ +#!./perl + +# This test harness will (eventually) test the "tie" functionality +# without the need for a *DBM* implementation. + +# Currently it only tests the untie warning + +chdir 't' if -d 't'; +@INC = "../lib"; +$ENV{PERL5LIB} = "../lib"; + +$|=1; + +# catch warnings into fatal errors +$SIG{__WARN__} = sub { die "WARNING: @_" } ; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +for (@prgs){ + my($prog,$expected) = split(/\nEXPECT\n/, $_); + eval "$prog" ; + $status = $?; + $results = $@ ; + $results =~ s/\n+$//; + $expected =~ s/\n+$//; + if ( $status or $results and $results !~ /^WARNING: $expected/){ + print STDERR "STATUS: $status\n"; + print STDERR "PROG: $prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +__END__ + +# standard behaviour, without any extra references +use Tie::Hash ; +tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference via tied +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference which is destroyed +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +$a = 0 ; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference via tied which is destroyed +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict behaviour, without any extra references +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# strict behaviour, with 1 extra references generating an error +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +untie %h; +EXPECT +untie attempted while 1 inner references still exist +######## + +# strict behaviour, with 1 extra references via tied generating an error +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +untie %h; +EXPECT +untie attempted while 1 inner references still exist +######## + +# strict behaviour, with 1 extra references which are destroyed +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict behaviour, with extra 1 references via tied which are destroyed +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict error behaviour, with 2 extra references +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +$b = tied %h ; +untie %h; +EXPECT +untie attempted while 2 inner references still exist +######## + +# strict behaviour, check scope of strictness. +#no warning 'untie'; +local $^W = 0 ; +use Tie::Hash ; +$A = tie %H, Tie::StdHash; +$C = $B = tied %H ; +{ + #use warning 'untie'; + local $^W = 1 ; + use Tie::Hash ; + tie %h, Tie::StdHash; + untie %h; +} +untie %H; +EXPECT diff --git a/gnu/usr.bin/perl/t/op/universal.t b/gnu/usr.bin/perl/t/op/universal.t new file mode 100644 index 00000000000..bd6c73afe99 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/universal.t @@ -0,0 +1,96 @@ +#!./perl +# +# check UNIVERSAL +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +print "1..72\n"; + +$a = {}; +bless $a, "Bob"; +print "not " unless $a->isa("Bob"); +print "ok 1\n"; + +package Human; +sub eat {} + +package Female; +@ISA=qw(Human); + +package Alice; +@ISA=qw(Bob Female); +sub drink {} +sub new { bless {} } + +$Alice::VERSION = 2.718; + +package main; + +my $i = 2; +sub test { print "not " unless shift; print "ok $i\n"; $i++; } + +$a = new Alice; + +test $a->isa("Alice"); + +test $a->isa("Bob"); + +test $a->isa("Female"); + +test $a->isa("Human"); + +test ! $a->isa("Male"); + +test $a->can("drink"); + +test $a->can("eat"); + +test ! $a->can("sleep"); + +my $b = 'abc'; +my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); +my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); +for ($p=0; $p < @refs; $p++) { + for ($q=0; $q < @vals; $q++) { + test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); + }; +}; + +test ! UNIVERSAL::can(23, "can"); + +test $a->can("VERSION"); + +test $a->can("can"); +test ! $a->can("export_tags"); # a method in Exporter + +test (eval { $a->VERSION }) == 2.718; + +test ! (eval { $a->VERSION(2.719) }) && + $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /; + +test (eval { $a->VERSION(2.718) }) && ! $@; + +my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +test $subs eq "VERSION can isa"; + +test $a->isa("UNIVERSAL"); + +# now use UNIVERSAL.pm and see what changes +eval "use UNIVERSAL"; + +test $a->isa("UNIVERSAL"); + +my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +# XXX import being here is really a bug +test $sub2 eq "VERSION can import isa"; + +eval 'sub UNIVERSAL::sleep {}'; +test $a->can("sleep"); + +test ! UNIVERSAL::can($b, "can"); + +test ! $a->can("export_tags"); # a method in Exporter diff --git a/gnu/usr.bin/perl/t/pragma/constant.t b/gnu/usr.bin/perl/t/pragma/constant.t new file mode 100644 index 00000000000..0095f3b627b --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/constant.t @@ -0,0 +1,141 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +BEGIN {$^W |= 1} # Insist upon warnings +use vars qw{ @warnings }; +BEGIN { # ...and save 'em for later + $SIG{'__WARN__'} = sub { push @warnings, @_ } +} +END { print @warnings } + +######################### We start with some black magic to print on failure. + +BEGIN { $| = 1; print "1..39\n"; } +END {print "not ok 1\n" unless $loaded;} +use constant; +$loaded = 1; +#print "# Version: $constant::VERSION\n"; +print "ok 1\n"; + +######################### End of black magic. + +use strict; + +sub test ($$;$) { + my($num, $bool, $diag) = @_; + if ($bool) { + print "ok $num\n"; + return; + } + print "not ok $num\n"; + return unless defined $diag; + $diag =~ s/\Z\n?/\n/; # unchomp + print map "# $num : $_", split m/^/m, $diag; +} + +use constant PI => 4 * atan2 1, 1; + +test 2, substr(PI, 0, 7) eq '3.14159'; +test 3, defined PI; + +sub deg2rad { PI * $_[0] / 180 } + +my $ninety = deg2rad 90; + +test 4, $ninety > 1.5707; +test 5, $ninety < 1.5708; + +use constant UNDEF1 => undef; # the right way +use constant UNDEF2 => ; # the weird way +use constant 'UNDEF3' ; # the 'short' way +use constant EMPTY => ( ) ; # the right way for lists + +test 6, not defined UNDEF1; +test 7, not defined UNDEF2; +test 8, not defined UNDEF3; +my @undef = UNDEF1; +test 9, @undef == 1; +test 10, not defined $undef[0]; +@undef = UNDEF2; +test 11, @undef == 0; +@undef = UNDEF3; +test 12, @undef == 0; +@undef = EMPTY; +test 13, @undef == 0; + +use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; +use constant COUNTLIST => reverse 1, 2, 3, 4, 5; +use constant COUNTLAST => (COUNTLIST)[-1]; + +test 14, COUNTDOWN eq '54321'; +my @cl = COUNTLIST; +test 15, @cl == 5; +test 16, COUNTDOWN eq join '', @cl; +test 17, COUNTLAST == 1; +test 18, (COUNTLIST)[1] == 4; + +use constant ABC => 'ABC'; +test 19, "abc${\( ABC )}abc" eq "abcABCabc"; + +use constant DEF => 'D', "\x45", chr 70; +test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f"; + +use constant SINGLE => "'"; +use constant DOUBLE => '"'; +use constant BACK => '\\'; +my $tt = BACK . SINGLE . DOUBLE ; +test 21, $tt eq q(\\'"); + +use constant MESS => q('"'\\"'"\\); +test 22, MESS eq q('"'\\"'"\\); +test 23, length(MESS) == 8; + +use constant TRAILING => '12 cats'; +{ + my $save_warn; + local $^W; + BEGIN { $save_warn = $^W; $^W = 0 } + test 24, TRAILING == 12; + BEGIN { $^W = $save_warn } +} +test 25, TRAILING eq '12 cats'; + +use constant LEADING => " \t1234"; +test 26, LEADING == 1234; +test 27, LEADING eq " \t1234"; + +use constant ZERO1 => 0; +use constant ZERO2 => 0.0; +use constant ZERO3 => '0.0'; +test 28, ZERO1 eq '0'; +test 29, ZERO2 eq '0'; +test 30, ZERO3 eq '0.0'; + +{ + package Other; + use constant PI => 3.141; +} + +test 31, (PI > 3.1415 and PI < 3.1416); +test 32, Other::PI == 3.141; + +use constant E2BIG => $! = 7; +test 33, E2BIG == 7; +# This is something like "Arg list too long", but the actual message +# text may vary, so we can't test much better than this. +test 34, length(E2BIG) > 6; +test 35, index(E2BIG, " ") > 0; + +test 36, @warnings == 0, join "\n", "unexpected warning", @warnings; +@warnings = (); # just in case +undef &PI; +test 37, @warnings && + ($warnings[0] =~ /Constant sub.* undefined/), + shift @warnings; + +test 38, @warnings == 0, "unexpected warning"; +test 39, $^W & 1, "Who disabled the warnings?"; diff --git a/gnu/usr.bin/perl/t/pragma/locale.t b/gnu/usr.bin/perl/t/pragma/locale.t new file mode 100644 index 00000000000..8e296db8a7c --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/locale.t @@ -0,0 +1,475 @@ +#!./perl -wT + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { + print "1..0\n"; + exit; + } +} + +use strict; + +my $have_setlocale = 0; +eval { + require POSIX; + import POSIX ':locale_h'; + $have_setlocale++; +}; + +print "1..", ($have_setlocale ? 102 : 98), "\n"; + +use vars qw($a + $English $German $French $Spanish + @C @English @German @French @Spanish + $Locale @Locale %iLocale %UPPER %lower @Neoalpha); + +$a = 'abc %'; + +sub ok { + my ($n, $result) = @_; + + print 'not ' unless ($result); + print "ok $n\n"; +} + +# First we'll do a lot of taint checking for locales. +# This is the easiest to test, actually, as any locale, +# even the default locale will taint under 'use locale'. + +sub is_tainted { # hello, camel two. + local $^W; # no warnings 'undef' + my $dummy; + not eval { $dummy = join("", @_), kill 0; 1 } +} + +sub check_taint ($$) { + ok $_[0], is_tainted($_[1]); +} + +sub check_taint_not ($$) { + ok $_[0], not is_tainted($_[1]); +} + +use locale; # engage locale and therefore locale taint. + +check_taint_not 1, $a; + +check_taint 2, uc($a); +check_taint 3, "\U$a"; +check_taint 4, ucfirst($a); +check_taint 5, "\u$a"; +check_taint 6, lc($a); +check_taint 7, "\L$a"; +check_taint 8, lcfirst($a); +check_taint 9, "\l$a"; + +check_taint 10, sprintf('%e', 123.456); +check_taint 11, sprintf('%f', 123.456); +check_taint 12, sprintf('%g', 123.456); +check_taint_not 13, sprintf('%d', 123.456); +check_taint_not 14, sprintf('%x', 123.456); + +$_ = $a; # untaint $_ + +$_ = uc($a); # taint $_ + +check_taint 15, $_; + +/(\w)/; # taint $&, $`, $', $+, $1. +check_taint 16, $&; +check_taint 17, $`; +check_taint 18, $'; +check_taint 19, $+; +check_taint 20, $1; +check_taint_not 21, $2; + +/(.)/; # untaint $&, $`, $', $+, $1. +check_taint_not 22, $&; +check_taint_not 23, $`; +check_taint_not 24, $'; +check_taint_not 25, $+; +check_taint_not 26, $1; +check_taint_not 27, $2; + +/(\W)/; # taint $&, $`, $', $+, $1. +check_taint 28, $&; +check_taint 29, $`; +check_taint 30, $'; +check_taint 31, $+; +check_taint 32, $1; +check_taint_not 33, $2; + +/(\s)/; # taint $&, $`, $', $+, $1. +check_taint 34, $&; +check_taint 35, $`; +check_taint 36, $'; +check_taint 37, $+; +check_taint 38, $1; +check_taint_not 39, $2; + +/(\S)/; # taint $&, $`, $', $+, $1. +check_taint 40, $&; +check_taint 41, $`; +check_taint 42, $'; +check_taint 43, $+; +check_taint 44, $1; +check_taint_not 45, $2; + +$_ = $a; # untaint $_ + +check_taint_not 46, $_; + +/(b)/; # this must not taint +check_taint_not 47, $&; +check_taint_not 48, $`; +check_taint_not 49, $'; +check_taint_not 50, $+; +check_taint_not 51, $1; +check_taint_not 52, $2; + +$_ = $a; # untaint $_ + +check_taint_not 53, $_; + +$b = uc($a); # taint $b +s/(.+)/$b/; # this must taint only the $_ + +check_taint 54, $_; +check_taint_not 55, $&; +check_taint_not 56, $`; +check_taint_not 57, $'; +check_taint_not 58, $+; +check_taint_not 59, $1; +check_taint_not 60, $2; + +$_ = $a; # untaint $_ + +s/(.+)/b/; # this must not taint +check_taint_not 61, $_; +check_taint_not 62, $&; +check_taint_not 63, $`; +check_taint_not 64, $'; +check_taint_not 65, $+; +check_taint_not 66, $1; +check_taint_not 67, $2; + +$b = $a; # untaint $b + +($b = $a) =~ s/\w/$&/; +check_taint 68, $b; # $b should be tainted. +check_taint_not 69, $a; # $a should be not. + +$_ = $a; # untaint $_ + +s/(\w)/\l$1/; # this must taint +check_taint 70, $_; +check_taint 71, $&; +check_taint 72, $`; +check_taint 73, $'; +check_taint 74, $+; +check_taint 75, $1; +check_taint_not 76, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\L$1/; # this must taint +check_taint 77, $_; +check_taint 78, $&; +check_taint 79, $`; +check_taint 80, $'; +check_taint 81, $+; +check_taint 82, $1; +check_taint_not 83, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\u$1/; # this must taint +check_taint 84, $_; +check_taint 85, $&; +check_taint 86, $`; +check_taint 87, $'; +check_taint 88, $+; +check_taint 89, $1; +check_taint_not 90, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\U$1/; # this must taint +check_taint 91, $_; +check_taint 92, $&; +check_taint 93, $`; +check_taint 94, $'; +check_taint 95, $+; +check_taint 96, $1; +check_taint_not 97, $2; + +# After all this tainting $a should be cool. + +check_taint_not 98, $a; + +# I think we've seen quite enough of taint. +# Let us do some *real* locale work now, +# unless setlocale() is missing (i.e. minitest). + +exit unless $have_setlocale; + +sub getalnum { + sort grep /\w/, map { chr } 0..255 +} + +sub locatelocale ($$@) { + my ($lcall, $alnum, @try) = @_; + + undef $$lcall; + + for (@try) { + local $^W = 0; # suppress "Subroutine LC_ALL redefined" + if (setlocale(&LC_ALL, $_)) { + $$lcall = $_; + @$alnum = &getalnum; + last; + } + } + + @$alnum = () unless (defined $$lcall); +} + +# Find some default locale + +locatelocale(\$Locale, \@Locale, qw(C POSIX)); + +# Find some English locale + +locatelocale(\$English, \@English, + qw(en_US.ISO8859-1 en_GB.ISO8859-1 + en en_US en_UK en_IE en_CA en_AU en_NZ + english english.iso88591 + american american.iso88591 + british british.iso88591 + )); + +# Find some German locale + +locatelocale(\$German, \@German, + qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1 + de de_DE de_AT de_CH + german german.iso88591)); + +# Find some French locale + +locatelocale(\$French, \@French, + qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1 + fr fr_FR fr_BE fr_CA fr_CH + french french.iso88591)); + +# Find some Spanish locale + +locatelocale(\$Spanish, \@Spanish, + qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1 + es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1 + es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1 + es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1 + es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1 + es es_AR es_BO es_CL + es_CO es_CR es_EC + es_ES es_GT es_MX + es_NI es_PA es_PE + es_PY es_SV es_UY es_VE + spanish spanish.iso88591)); + +# Select the largest of the alpha(num)bets. + +($Locale, @Locale) = ($English, @English) + if (length(@English) > length(@Locale)); +($Locale, @Locale) = ($German, @German) + if (length(@German) > length(@Locale)); +($Locale, @Locale) = ($French, @French) + if (length(@French) > length(@Locale)); +($Locale, @Locale) = ($Spanish, @Spanish) + if (length(@Spanish) > length(@Locale)); + +print "# Locale = $Locale\n"; +print "# Alnum_ = @Locale\n"; + +{ + local $^W = 0; + setlocale(&LC_ALL, $Locale); +} + +{ + my $i = 0; + + for (@Locale) { + $iLocale{$_} = $i++; + } +} + +# Sieve the uppercase and the lowercase. + +for (@Locale) { + if (/[^\d_]/) { # skip digits and the _ + if (lc eq $_) { + $UPPER{$_} = uc; + } else { + $lower{$_} = lc; + } + } +} + +# Find the alphabets that are not alphabets in the default locale. + +{ + no locale; + + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + } +} + +@Neoalpha = sort @Neoalpha; + +# Test \w. + +{ + my $word = join('', @Neoalpha); + + $word =~ /^(\w*)$/; + + print 'not ' if ($1 ne $word); +} +print "ok 99\n"; + +# Find places where the collation order differs from the default locale. + +print "# testing 100\n"; +{ + my (@k, $i, $j, @d); + + { + no locale; + + @k = sort (keys %UPPER, keys %lower); + } + + for ($i = 0; $i < @k; $i++) { + for ($j = $i + 1; $j < @k; $j++) { + if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) { + push(@d, [$k[$j], $k[$i]]); + } + } + } + + # Cross-check those places. + + for (@d) { + ($i, $j) = @$_; + if ($i gt $j) { + print "# failed 100 at:\n"; + print "# i = $i, j = $j, i ", + $i le $j ? 'le' : 'gt', " j\n"; + print 'not '; + last; + } + } +} +print "ok 100\n"; + +# Cross-check whole character set. + +print "# testing 101\n"; +for (map { chr } 0..255) { + if (/\w/ and /\W/) { print 'not '; last } + if (/\d/ and /\D/) { print 'not '; last } + if (/\s/ and /\S/) { print 'not '; last } + if (/\w/ and /\D/ and not /_/ and + not (exists $UPPER{$_} or exists $lower{$_})) { + print "# failed 101 at:\n"; + print "# ", ord($_), " '$_'\n"; + print 'not '; + last; + } +} +print "ok 101\n"; + +# Test for read-onlys. + +{ + no locale; + $a = "qwerty"; + { + use locale; + print "not " if $a cmp "qwerty"; + } +} +print "ok 102\n"; + +# This test must be the last one because its failure is not fatal. +# The @Locale should be internally consistent. +# Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> +# for inventing a way to test for ordering consistency +# without requiring any particular order. +# ++$jhi;#@iki.fi + +print "# testing 103\n"; +{ + my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign); + + for (0..9) { + # Select a slice. + $from = int(($_*@Locale)/10); + $to = $from + int(@Locale/10); + $to = $#Locale if ($to > $#Locale); + $lesser = join('', @Locale[$from..$to]); + # Select a slice one character on. + $from++; $to++; + $to = $#Locale if ($to > $#Locale); + $greater = join('', @Locale[$from..$to]); + ($yes, $no, $sign) = ($lesser lt $greater + ? (" ", "not ", 1) + : ("not ", " ", -1)); + # all these tests should FAIL (return 0). + @test = + ( + $no.' ($lesser lt $greater)', # 0 + $no.' ($lesser le $greater)', # 1 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 + $yes.' ($lesser ge $greater)', # 4 + $yes.' ($lesser gt $greater)', # 5 + $yes.' ($greater lt $lesser )', # 6 + $yes.' ($greater le $lesser )', # 7 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 + $no.' ($greater ge $lesser )', # 10 + $no.' ($greater gt $lesser )', # 11 + 'not (($lesser cmp $greater) == -$sign)' # 12 + ); + @test{@test} = 0 x @test; + $test = 0; + for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} } + if ($test) { + print "# failed 103 at:\n"; + print "# lesser = '$lesser'\n"; + print "# greater = '$greater'\n"; + print "# lesser cmp greater = ", $lesser cmp $greater, "\n"; + print "# greater cmp lesser = ", $greater cmp $lesser, "\n"; + print "# (greater) from = $from, to = $to\n"; + for my $ti (@test) { + printf("# %-40s %-4s", $ti, + $test{$ti} ? 'FAIL' : 'ok'); + if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { + printf("(%s == %4d)", $1, eval $1); + } + print "\n"; + } + + warn "The locale definition on your system may have errors.\n"; + last; + } + } +} + +# eof diff --git a/gnu/usr.bin/perl/t/pragma/overload.t b/gnu/usr.bin/perl/t/pragma/overload.t new file mode 100644 index 00000000000..42d045741de --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/overload.t @@ -0,0 +1,363 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + +package Oscalar; +use overload ( + # Anonymous subroutines: +'+' => sub {new Oscalar $ {$_[0]}+$_[1]}, +'-' => sub {new Oscalar + $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, +'<=>' => sub {new Oscalar + $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, +'cmp' => sub {new Oscalar + $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, +'*' => sub {new Oscalar ${$_[0]}*$_[1]}, +'/' => sub {new Oscalar + $_[2]? $_[1]/${$_[0]} : + ${$_[0]}/$_[1]}, +'%' => sub {new Oscalar + $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, +'**' => sub {new Oscalar + $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, + +qw( +"" stringify +0+ numify) # Order of arguments unsignificant +); + +sub new { + my $foo = $_[1]; + bless \$foo, $_[0]; +} + +sub stringify { "${$_[0]}" } +sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead + # comparing to direct compilation based on + # stringify + +package main; + +$test = 0; +$| = 1; +print "1..",&last,"\n"; + +sub test { + $test++; if (shift) {print "ok $test\n";1} else {print "not ok $test\n";0} +} + +$a = new Oscalar "087"; +$b= "$a"; + +# All test numbers in comments are off by 1. +# So much for hard-wiring them in :-) To fix this: +test(1); # 1 + +test ($b eq $a); # 2 +test ($b eq "087"); # 3 +test (ref $a eq "Oscalar"); # 4 +test ($a eq $a); # 5 +test ($a eq "087"); # 6 + +$c = $a + 7; + +test (ref $c eq "Oscalar"); # 7 +test (!($c eq $a)); # 8 +test ($c eq "94"); # 9 + +$b=$a; + +test (ref $a eq "Oscalar"); # 10 + +$b++; + +test (ref $b eq "Oscalar"); # 11 +test ( $a eq "087"); # 12 +test ( $b eq "88"); # 13 +test (ref $a eq "Oscalar"); # 14 + +$c=$b; +$c-=$a; + +test (ref $c eq "Oscalar"); # 15 +test ( $a eq "087"); # 16 +test ( $c eq "1"); # 17 +test (ref $a eq "Oscalar"); # 18 + +$b=1; +$b+=$a; + +test (ref $b eq "Oscalar"); # 19 +test ( $a eq "087"); # 20 +test ( $b eq "88"); # 21 +test (ref $a eq "Oscalar"); # 22 + +eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; + +$b=$a; + +test (ref $a eq "Oscalar"); # 23 + +$b++; + +test (ref $b eq "Oscalar"); # 24 +test ( $a eq "087"); # 25 +test ( $b eq "88"); # 26 +test (ref $a eq "Oscalar"); # 27 + +package Oscalar; +$dummy=bless \$dummy; # Now cache of method should be reloaded +package main; + +$b=$a; +$b++; + +test (ref $b eq "Oscalar"); # 28 +test ( $a eq "087"); # 29 +test ( $b eq "88"); # 30 +test (ref $a eq "Oscalar"); # 31 + + +eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; + +$b=$a; + +test (ref $a eq "Oscalar"); # 32 + +$b++; + +test (ref $b eq "Oscalar"); # 33 +test ( $a eq "087"); # 34 +test ( $b eq "88"); # 35 +test (ref $a eq "Oscalar"); # 36 + +package Oscalar; +$dummy=bless \$dummy; # Now cache of method should be reloaded +package main; + +$b++; + +test (ref $b eq "Oscalar"); # 37 +test ( $a eq "087"); # 38 +test ( $b eq "90"); # 39 +test (ref $a eq "Oscalar"); # 40 + +$b=$a; +$b++; + +test (ref $b eq "Oscalar"); # 41 +test ( $a eq "087"); # 42 +test ( $b eq "89"); # 43 +test (ref $a eq "Oscalar"); # 44 + + +test ($b? 1:0); # 45 + +eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; + package Oscalar; + local $new=$ {$_[0]}; + bless \$new } ) ]; + +$b=new Oscalar "$a"; + +test (ref $b eq "Oscalar"); # 46 +test ( $a eq "087"); # 47 +test ( $b eq "087"); # 48 +test (ref $a eq "Oscalar"); # 49 + +$b++; + +test (ref $b eq "Oscalar"); # 50 +test ( $a eq "087"); # 51 +test ( $b eq "89"); # 52 +test (ref $a eq "Oscalar"); # 53 +test ($copies == 0); # 54 + +$b+=1; + +test (ref $b eq "Oscalar"); # 55 +test ( $a eq "087"); # 56 +test ( $b eq "90"); # 57 +test (ref $a eq "Oscalar"); # 58 +test ($copies == 0); # 59 + +$b=$a; +$b+=1; + +test (ref $b eq "Oscalar"); # 60 +test ( $a eq "087"); # 61 +test ( $b eq "88"); # 62 +test (ref $a eq "Oscalar"); # 63 +test ($copies == 0); # 64 + +$b=$a; +$b++; + +test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 +test ( $a eq "087"); # 66 +test ( $b eq "89"); # 67 +test (ref $a eq "Oscalar"); # 68 +test ($copies == 1); # 69 + +eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; + $_[0] } ) ]; +$c=new Oscalar; # Cause rehash + +$b=$a; +$b+=1; + +test (ref $b eq "Oscalar"); # 70 +test ( $a eq "087"); # 71 +test ( $b eq "90"); # 72 +test (ref $a eq "Oscalar"); # 73 +test ($copies == 2); # 74 + +$b+=$b; + +test (ref $b eq "Oscalar"); # 75 +test ( $b eq "360"); # 76 +test ($copies == 2); # 77 +$b=-$b; + +test (ref $b eq "Oscalar"); # 78 +test ( $b eq "-360"); # 79 +test ($copies == 2); # 80 + +$b=abs($b); + +test (ref $b eq "Oscalar"); # 81 +test ( $b eq "360"); # 82 +test ($copies == 2); # 83 + +$b=abs($b); + +test (ref $b eq "Oscalar"); # 84 +test ( $b eq "360"); # 85 +test ($copies == 2); # 86 + +eval q[package Oscalar; + use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} + : "_.${$_[0]}._" x $_[1])}) ]; + +$a=new Oscalar "yy"; +$a x= 3; +test ($a eq "_.yy.__.yy.__.yy._"); # 87 + +eval q[package Oscalar; + use overload ('.' => sub {new Oscalar ( $_[2] ? + "_.$_[1].__.$ {$_[0]}._" + : "_.$ {$_[0]}.__.$_[1]._")}) ]; + +$a=new Oscalar "xx"; + +test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 + +# Check inheritance of overloading; +{ + package OscalarI; + @ISA = 'Oscalar'; +} + +$aI = new OscalarI "$a"; +test (ref $aI eq "OscalarI"); # 89 +test ("$aI" eq "xx"); # 90 +test ($aI eq "xx"); # 91 +test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 + +# Here we test blessing to a package updates hash + +eval "package Oscalar; no overload '.'"; + +test ("b${a}" eq "_.b.__.xx._"); # 93 +$x="1"; +bless \$x, Oscalar; +test ("b${a}c" eq "bxxc"); # 94 +new Oscalar 1; +test ("b${a}c" eq "bxxc"); # 95 + +# Negative overloading: + +$na = eval { ~$a }; +test($@ =~ /no method found/); # 96 + +# Check AUTOLOADING: + +*Oscalar::AUTOLOAD = + sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; + goto &{"Oscalar::$AUTOLOAD"}}; + +eval "package Oscalar; sub comple; use overload '~' => 'comple'"; + +$na = eval { ~$a }; # Hash was not updated +test($@ =~ /no method found/); # 97 + +bless \$x, Oscalar; + +$na = eval { ~$a }; # Hash updated +warn "`$na', $@" if $@; +test !$@; # 98 +test($na eq '_!_xx_!_'); # 99 + +$na = 0; + +$na = eval { ~$aI }; # Hash was not updated +test($@ =~ /no method found/); # 100 + +bless \$x, OscalarI; + +$na = eval { ~$aI }; +print $@; + +test !$@; # 101 +test($na eq '_!_xx_!_'); # 102 + +eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; + +$na = eval { $aI >> 1 }; # Hash was not updated +test($@ =~ /no method found/); # 103 + +bless \$x, OscalarI; + +$na = 0; + +$na = eval { $aI >> 1 }; +print $@; + +test !$@; # 104 +test($na eq '_!_xx_!_'); # 105 + +# warn overload::Method($a, '0+'), "\n"; +test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 +test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 +test (overload::Overloaded($aI)); # 108 +test (!overload::Overloaded('overload')); # 109 + +test (! defined overload::Method($aI, '<<')); # 110 +test (! defined overload::Method($a, '<')); # 111 + +test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 +test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 + +# Check overloading by methods (specified deep in the ISA tree). +{ + package OscalarII; + @ISA = 'OscalarI'; + sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} + eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; +} + +$aaII = "087"; +$aII = \$aaII; +bless $aII, 'OscalarII'; +bless \$fake, 'OscalarI'; # update the hash +test(($aI | 3) eq '_<<_xx_<<_'); # 114 +# warn $aII << 3; +test(($aII << 3) eq '_<<_087_<<_'); # 115 + +# Last test is: +sub last {115} diff --git a/gnu/usr.bin/perl/t/pragma/strict-refs b/gnu/usr.bin/perl/t/pragma/strict-refs new file mode 100644 index 00000000000..7bf1556e10a --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict-refs @@ -0,0 +1,295 @@ +Check strict refs functionality + +__END__ + +# no strict, should build & run ok. +my $fred ; +$b = "fred" ; +$a = $$b ; +$c = ${"def"} ; +$c = @{"def"} ; +$c = %{"def"} ; +$c = *{"def"} ; +$c = \&{"def"} ; +$c = def->[0]; +$c = def->{xyz}; +EXPECT + +######## + +# strict refs - error +use strict ; +my $fred ; +my $a = ${"fred"} ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $fred ; +my $a = ${"fred"} ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = $$b ; +EXPECT +Can't use an undefined value as a SCALAR reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = @$b ; +EXPECT +Can't use an undefined value as an ARRAY reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = %$b ; +EXPECT +Can't use an undefined value as a HASH reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = *$b ; +EXPECT +Can't use an undefined value as a symbol reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $a = fred->[0] ; +EXPECT +Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4. +######## + +# strict refs - error +use strict 'refs' ; +my $a = fred->{barney} ; +EXPECT +Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4. +######## + +# strict refs - no error +use strict ; +no strict 'refs' ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +use strict qw(subs vars) ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +use strict 'refs' ; +my $fred ; +my $b = \$fred ; +my $a = $$b ; +EXPECT + +######## + +# Check runtime scope of strict refs pragma +use strict 'refs'; +my $fred ; +my $b = "fred" ; +{ + no strict ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + $a = sub { my $c = $$b ; } +} +&$a ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + + +--FILE-- abc +my $a = ${"Fred"} ; +1; +--FILE-- +use strict 'refs' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'refs' ; +1; +--FILE-- +require "./abc"; +my $a = ${"Fred"} ; +EXPECT + +######## + +--FILE-- abc +use strict 'refs' ; +my $a = ${"Fred"} ; +1; +--FILE-- +${"Fred"} ; +require "./abc"; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. +######## + +--FILE-- abc.pm +use strict 'refs' ; +my $a = ${"Fred"} ; +1; +--FILE-- +my $a = ${"Fred"} ; +use abc; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'refs' ; + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval { + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval { + no strict ; + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + my $a = ${"Fred"} ; +'; print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'refs' ; + my $a = ${"Fred"} ; +]; print STDERR $@; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval ' + my $a = ${"Fred"} ; +'; print STDERR $@ ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval ' + no strict ; + my $a = ${"Fred"} ; +'; print STDERR $@; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. diff --git a/gnu/usr.bin/perl/t/pragma/strict-subs b/gnu/usr.bin/perl/t/pragma/strict-subs new file mode 100644 index 00000000000..43fce712d57 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict-subs @@ -0,0 +1,279 @@ +Check strict subs functionality + +__END__ + +# no strict, should build & run ok. +Fred ; +my $fred ; +$b = "fred" ; +$a = $$b ; +EXPECT + +######## + +use strict qw(refs vars); +Fred ; +EXPECT + +######## + +use strict ; +no strict 'subs' ; +Fred ; +EXPECT + +######## + +# strict subs - error +use strict 'subs' ; +Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error +use strict ; +Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - no error +use strict 'subs' ; +sub Fred {} +Fred ; +EXPECT + +######## + +# Check compile time scope of strict subs pragma +use strict 'subs' ; +{ + no strict ; + my $a = Fred ; +} +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict subs pragma +no strict; +{ + use strict 'subs' ; + my $a = Fred ; +} +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +use strict 'vars' ; +{ + no strict ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 8. +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +no strict; +{ + use strict 'vars' ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check runtime scope of strict refs pragma +use strict 'refs'; +my $fred ; +my $b = "fred" ; +{ + no strict ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + $a = sub { my $c = $$b ; } +} +&$a ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +use strict 'subs' ; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 3. +Execution of - aborted due to compilation errors. +######## + +--FILE-- abc +my $a = Fred ; +1; +--FILE-- +use strict 'subs' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'subs' ; +1; +--FILE-- +require "./abc"; +my $a = Fred ; +EXPECT + +######## + +--FILE-- abc +use strict 'subs' ; +my $a = Fred ; +1; +--FILE-- +Fred ; +require "./abc"; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2. +Compilation failed in require at - line 2. +######## + +--FILE-- abc.pm +use strict 'subs' ; +my $a = Fred ; +1; +--FILE-- +Fred ; +use abc; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2. +Compilation failed in require at - line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'subs' ; + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval { + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 5. +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval { + no strict ; + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 9. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + Fred ; +'; print STDERR $@ ; +Fred ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'subs' ; + Fred ; +]; print STDERR $@; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval ' + Fred ; +'; print STDERR $@ ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval ' + no strict ; + my $a = Fred ; +'; print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. diff --git a/gnu/usr.bin/perl/t/pragma/strict-vars b/gnu/usr.bin/perl/t/pragma/strict-vars new file mode 100644 index 00000000000..7ca9843c2c0 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict-vars @@ -0,0 +1,223 @@ +Check strict vars functionality + +__END__ + +# no strict, should build & run ok. +Fred ; +my $fred ; +$b = "fred" ; +$a = $$b ; +EXPECT + +######## + +use strict qw(subs refs) ; +$fred ; +EXPECT + +######## + +use strict ; +no strict 'vars' ; +$fred ; +EXPECT + +######## + +# strict vars - no error +use strict 'vars' ; +use vars qw( $freddy) ; +local $abc::joe ; +my $fred ; +my $b = \$fred ; +$Fred::ABC = 1 ; +$freddy = 2 ; +EXPECT + +######## + +# strict vars - error +use strict ; +$fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict vars - error +use strict 'vars' ; +$fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict vars - error +use strict 'vars' ; +local $fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +use strict 'vars' ; +{ + no strict ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 8. +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +no strict; +{ + use strict 'vars' ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +--FILE-- abc +$joe = 1 ; +1; +--FILE-- +use strict 'vars' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'vars' ; +1; +--FILE-- +require "./abc"; +$joe = 1 ; +EXPECT + +######## + +--FILE-- abc +use strict 'vars' ; +$joe = 1 ; +1; +--FILE-- +$joe = 1 ; +require "./abc"; +EXPECT +Variable "$joe" is not imported at ./abc line 2. +Global symbol "joe" requires explicit package name at ./abc line 2. +Compilation failed in require at - line 2. +######## + +--FILE-- abc.pm +use strict 'vars' ; +$joe = 1 ; +1; +--FILE-- +$joe = 1 ; +use abc; +EXPECT +Variable "$joe" is not imported at abc.pm line 2. +Global symbol "joe" requires explicit package name at abc.pm line 2. +Compilation failed in require at - line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'vars' ; + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval { + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 5. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval { + no strict ; + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 9. +Global symbol "joe" requires explicit package name at - line 9. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + $joe = 1 ; +'; print STDERR $@ ; +$joe = 1 ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'vars' ; + $joe = 1 ; +]; print STDERR $@; +EXPECT +Global symbol "joe" requires explicit package name at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval ' + $joe = 1 ; +'; print STDERR $@ ; +EXPECT +Global symbol "joe" requires explicit package name at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval ' + no strict ; + $joe = 1 ; +'; print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. diff --git a/gnu/usr.bin/perl/t/pragma/strict.t b/gnu/usr.bin/perl/t/pragma/strict.t new file mode 100644 index 00000000000..fc3282089fa --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict.t @@ -0,0 +1,93 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile; } } + +my @prgs = () ; + +foreach (sort glob("pragma/strict-*")) { + + next if /(~|\.orig)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} diff --git a/gnu/usr.bin/perl/t/pragma/subs.t b/gnu/usr.bin/perl/t/pragma/subs.t new file mode 100644 index 00000000000..056c4bd7cf4 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/subs.t @@ -0,0 +1,132 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; +undef $/; +my @prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} + +__END__ + +# Error - not predeclaring a sub +Fred 1,2 ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +Execution of - aborted due to compilation errors. +######## + +# Error - not predeclaring a sub in time +Fred 1,2 ; +use subs qw( Fred ) ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +BEGIN not safe after errors--compilation aborted at - line 4. +######## + +# AOK +use subs qw( Fred) ; +Fred 1,2 ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function +use subs qw( open ) ; +open 1,2 ; +sub open { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +--FILE-- abc +Fred 1,2 ; +1; +--FILE-- +use subs qw( Fred ) ; +require "./abc" ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# check that it isn't affected by block scope +{ + use subs qw( Fred ) ; +} +Fred 1, 2; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 diff --git a/gnu/usr.bin/perl/t/pragma/warn-1global b/gnu/usr.bin/perl/t/pragma/warn-1global new file mode 100644 index 00000000000..33252731b0e --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/warn-1global @@ -0,0 +1,146 @@ +Check existing $^W functionality + +__END__ + +# warnable code, warnings disabled +$a =+ 3 ; +EXPECT + +######## +-w +# warnable code, warnings enabled via command line switch +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +######## +#! perl -w +# warnable code, warnings enabled via #! line +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +######## + +# warnable code, warnings enabled via compile time $^W +BEGIN { $^W = 1 } +$a =+ 3 ; +EXPECT +Reversed += operator at - line 4. +######## + +# compile-time warnable code, warnings enabled via runtime $^W +# so no warning printed. +$^W = 1 ; +$a =+ 3 ; +EXPECT + +######## + +# warnable code, warnings enabled via runtime $^W +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 4. +######## + +# warnings enabled at compile time, disabled at run time +BEGIN { $^W = 1 } +$^W = 0 ; +my $b ; chop $b ; +EXPECT + +######## + +# warnings disabled at compile time, enabled at run time +BEGIN { $^W = 0 } +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 5. +######## +-w +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +#! perl -w +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +$^W = 0; +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT + +######## + +--FILE-- abcd +$^W = 1; +1 ; +--FILE-- +$^W =0 ; +require "./abcd"; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 3. +######## + +$^W = 1; +eval "my $b ; chop $b ;" ; +EXPECT +Use of uninitialized value at - line 3. +Use of uninitialized value at - line 3. +######## + +eval "$^W = 1;" ; +my $b ; chop $b ; +EXPECT + +######## + +eval {$^W = 1;} ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 3. +######## + +{ + local ($^W) = 1; +} +my $b ; chop $b ; +EXPECT + +######## + +my $a ; chop $a ; +{ + local ($^W) = 1; + my $b ; chop $b ; +} +my $c ; chop $c ; +EXPECT +Use of uninitialized value at - line 5. diff --git a/gnu/usr.bin/perl/t/pragma/warning.t b/gnu/usr.bin/perl/t/pragma/warning.t new file mode 100644 index 00000000000..fa0301ea6a6 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/warning.t @@ -0,0 +1,94 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +my @prgs = () ; + +foreach (sort glob("pragma/warn-*")) { + + next if /(~|\.orig)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + $switch =~ s/(-\S*[A-Z]\S*)/"-$1"/ if $Is_VMS; # protect uc switches + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} diff --git a/gnu/usr.bin/perl/utils/splain.PL b/gnu/usr.bin/perl/utils/splain.PL new file mode 100644 index 00000000000..75b5e2f3f61 --- /dev/null +++ b/gnu/usr.bin/perl/utils/splain.PL @@ -0,0 +1,46 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries: +# $startperl +# $perlpath +# $eunicefix + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +# Open input file before creating output file. +$IN = '../lib/diagnostics.pm'; +open IN or die "Can't open $IN: $!\n"; + +# Create output file. +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +while (<IN>) { + print OUT unless /^package diagnostics/; +} + +close IN; + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt b/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt new file mode 100644 index 00000000000..9dc721d36b0 --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt @@ -0,0 +1,21 @@ +VMS::DCLsym is an extension to Perl 5 which allows it to manipulate DCL symbols +via an object-oriented or tied-hash interface. + +In order to build the extension, just say + +$ Perl Makefile.PL +$ MMK + +in the directory containing the source files. Once it's built, you can run the +test script by saying + +$ Perl "-Iblib" test.pl + +Finally, if you want to make it part of your regular Perl library, you can say +$ MMK install + +If you have any problems or suggestions, please feel free to let me know. + +Regards, +Charles Bailey bailey@genetics.upenn.edu +17-Aug-1995 diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm new file mode 100644 index 00000000000..44c4b84a654 --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm @@ -0,0 +1,270 @@ +package VMS::DCLsym; + +use Carp; +use DynaLoader; +use vars qw( @ISA $VERSION ); +use strict; + +# Package globals +@ISA = ( 'DynaLoader' ); +$VERSION = '1.01'; +my(%Locsyms) = ( ':ID' => 'LOCAL' ); +my(%Gblsyms) = ( ':ID' => 'GLOBAL'); +my $DoCache = 1; +my $Cache_set = 0; + + +#====> OO methods + +sub new { + my($pkg,$type) = @_; + bless { TYPE => $type }, $pkg; +} + +sub DESTROY { } + +sub getsym { + my($self,$name) = @_; + my($val,$table); + + if (($val,$table) = _getsym($name)) { + if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; } + else { $Locsyms{$name} = $val; } + } + wantarray ? ($val,$table) : $val; +} + +sub setsym { + my($self,$name,$val,$table) = @_; + + $table = $self->{TYPE} unless $table; + if (_setsym($name,$val,$table)) { + if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; } + else { $Locsyms{$name} = $val; } + 1; + } + else { 0; } +} + +sub delsym { + my($self,$name,$table) = @_; + + $table = $self->{TYPE} unless $table; + if (_delsym($name,$table)) { + if ($table eq 'GLOBAL') { delete $Gblsyms{$name}; } + else { delete $Locsyms{$name}; } + 1; + } + else { 0; } +} + +sub clearcache { + my($self,$perm) = @_; + my($old); + + $Cache_set = 0; + %Locsyms = ( ':ID' => 'LOCAL'); + %Gblsyms = ( ':ID' => 'GLOBAL'); + $old = $DoCache; + $DoCache = $perm if defined($perm); + $old; +} + +#====> TIEHASH methods + +sub TIEHASH { + $_[0]->new(@_); +} + +sub FETCH { + my($self,$name) = @_; + if ($name eq ':GLOBAL') { $self->{TYPE} eq 'GLOBAL'; } + elsif ($name eq ':LOCAL' ) { $self->{TYPE} eq 'LOCAL'; } + else { scalar($self->getsym($name)); } +} + +sub STORE { + my($self,$name,$val) = @_; + if ($name eq ':GLOBAL') { $self->{TYPE} = 'GLOBAL'; } + elsif ($name eq ':LOCAL' ) { $self->{TYPE} = 'LOCAL'; } + else { $self->setsym($name,$val); } +} + +sub DELETE { + my($self,$name) = @_; + + $self->delsym($name); +} + +sub FIRSTKEY { + my($self) = @_; + my($name,$eqs,$val); + + if (!$DoCache || !$Cache_set) { + # We should eventually replace this with a C routine which walks the + # CLI symbol table directly. If I ever get 'hold of an I&DS manual . . . + open(P,'Show Symbol * |'); + while (<P>) { + ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/ + or carp "VMS::CLISym: unparseable line $_"; + $name =~ s#\*##; + $val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/; + if ($eqs eq '==') { $Gblsyms{$name} = $val; } + else { $Locsyms{$name} = $val; } + } + close P; + $Cache_set = 1; + } + $self ->{IDX} = 0; + $self->{CACHE} = $self->{TYPE} eq 'GLOBAL' ? \%Gblsyms : \%Locsyms; + while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) { + if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; } + $self->{CACHE} = \%Gblsyms; + } + $name; +} + +sub NEXTKEY { + my($self) = @_; + my($name,$val); + + while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) { + if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; } + $self->{CACHE} = \%Gblsyms; + } + $name; +} + + +sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 } + +sub CLEAR { } + + +bootstrap VMS::DCLsym; + +1; + +__END__ + +=head1 NAME + +VMS::DCLsym - Perl extension to manipulate DCL symbols + +=head1 SYNOPSIS + + tie %allsyms, VMS::DCLsym; + tie %cgisyms, VMS::DCLsym, 'GLOBAL'; + + + $handle = new VMS::DCLsyms; + $value = $handle->getsym($name); + $handle->setsym($name,$value,'GLOBAL') or die "Can't create symbol: $!\n"; + $handle->delsym($name,'LOCAL') or die "Can't delete symbol: $!\n"; + $handle->clearcache(); + +=head1 DESCRIPTION + +The VMS::DCLsym extension provides access to DCL symbols using a +tied hash interface. This allows Perl scripts to manipulate symbols in +a manner similar to the way in which logical names are manipulated via +the built-in C<%ENV> hash. Alternatively, one can call methods in this +package directly to read, create, and delete symbols. + +=head2 Tied hash interface + +This interface lets you treat the DCL symbol table as a Perl associative array, +in which the key of each element is the symbol name, and the value of the +element is that symbol's value. Case is not significant in the key string, as +DCL converts symbol names to uppercase, but it is significant in the value +string. All of the usual operations on associative arrays are supported. +Reading an element retrieves the current value of the symbol, assigning to it +defines a new symbol (or overwrites the old value of an existing symbol), and +deleting an element deletes the corresponding symbol. Setting an element to +C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null +string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out +whether a default symbol table has been specified for this hash (see C<table> +below), or set either or these keys to specify a default symbol table. + +When you call the C<tie> function to bind an associative array to this package, +you may specify as an optional argument the symbol table in which you wish to +create and delete symbols. If the argument is the string 'GLOBAL', then the +global symbol table is used; any other string causes the local symbol table to +be used. Note that this argument does not affect attempts to read symbols; if +a symbol with the specified name exists in the local symbol table, it is always +returned in preference to a symbol by the same name in the global symbol table. + +=head2 Object interface + +Although it's less convenient in some ways than the tied hash interface, you +can also call methods directly to manipulate individual symbols. In some +cases, this allows you finer control than using a tied hash aggregate. The +following methods are supported: + +=over + +=item new + +This creates a C<VMS::DCLsym> object which can be used as a handle for later +method calls. The single optional argument specifies the symbol table used +by default in future method calls, in the same way as the optional argument to +C<tie> described above. + +=item getsym + +If called in a scalar context, C<getsym> returns the value of the symbol whose +name is given as the argument to the call, or C<undef> if no such symbol +exists. Symbols in the local symbol table are always used in preference to +symbols in the global symbol table. If called in an array context, C<getsym> +returns a two-element list, whose first element is the value of the symbol, and +whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table +from which the symbol's value was read. + +=item setsym + +The first two arguments taken by this method are the name of the symbol and the +value which should be assigned to it. The optional third argument is a string +specifying the symbol table to be used; 'GLOBAL' specifies the global symbol +table, and any other string specifies the local symbol table. If this argument +is omitted, the default symbol table for the object is used. C<setsym> returns +TRUE if successful, and FALSE otherwise. + +=item delsym + +This method deletes the symbol whose name is given as the first argument. The +optional second argument specifies the symbol table, as described above under +C<setsym>. It returns TRUE if the symbol was successfully deleted, and FALSE +if it was not. + +=item clearcache + +Because of the overhead associated with obtaining the list of defined symbols +for the tied hash iterator, it is only done once, and the list is reused for +subsequent iterations. Changes to symbols made through this package are +recorded, but in the rare event that someone changes the process' symbol table +from outside (as is possible using some software from the net), the iterator +will be out of sync with the symbol table. If you expect this to happen, you +can reset the cache by calling this method. In addition, if you pass a FALSE +value as the first argument, caching will be disabled. It can be reenabled +later by calling C<clearcache> again with a TRUE value as the first argument. +It returns TRUE or FALSE to indicate whether caching was previously enabled or +disabled, respectively. + +This method is a stopgap until we can incorporate code into this extension to +traverse the process' symbol table directly, so it may disappear in a future +version of this package. + +=head1 AUTHOR + +Charles Bailey bailey@genetics.upenn.edu + +=head1 VERSION + +1.01 08-Dec-1996 + +=head1 BUGS + +The list of symbols for the iterator is assembled by spawning off a +subprocess, which can be slow. Ideally, we should just traverse the +process' symbol table directly from C. + diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs new file mode 100644 index 00000000000..3918eb11e57 --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs @@ -0,0 +1,151 @@ +/* VMS::DCLsym - manipulate DCL symbols + * + * Version: 1.0 + * Author: Charles Bailey bailey@genetics.upenn.edu + * Revised: 17-Aug-1995 + * + * + * Revision History: + * + * 1.0 17-Aug-1995 Charles Bailey bailey@genetics.upenn.edu + * original production version + */ + +#include <descrip.h> +#include <lib$routines.h> +#include <libclidef.h> +#include <libdef.h> +#include <ssdef.h> +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +MODULE = VMS::DCLsym PACKAGE = VMS::DCLsym + +void +_getsym(name) + SV * name + PPCODE: + { + struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, + valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; + STRLEN namlen; + int tbltype; + unsigned long int retsts; + SETERRNO(0,SS$_NORMAL); + if (!name) { + PUSHs(sv_newmortal()); + SETERRNO(EINVAL,LIB$_INVARG); + return; + } + namdsc.dsc$a_pointer = SvPV(name,namlen); + namdsc.dsc$w_length = (unsigned short int) namlen; + retsts = lib$get_symbol(&namdsc,&valdsc,0,&tbltype); + if (retsts & 1) { + PUSHs(sv_2mortal(newSVpv(valdsc.dsc$w_length ? + valdsc.dsc$a_pointer : "",valdsc.dsc$w_length))); + if (GIMME) { + EXTEND(sp,2); /* just in case we're at the end of the stack */ + if (tbltype == LIB$K_CLI_LOCAL_SYM) + PUSHs(sv_2mortal(newSVpv("LOCAL",5))); + else + PUSHs(sv_2mortal(newSVpv("GLOBAL",6))); + } + _ckvmssts(lib$sfree1_dd(&valdsc)); + } + else { + ST(0) = &sv_undef; /* error - we're returning undef, if anything */ + switch (retsts) { + case LIB$_NOSUCHSYM: + break; /* nobody home */; + case LIB$_INVSYMNAM: /* user errors; set errno return undef */ + case LIB$_INSCLIMEM: + case LIB$_NOCLI: + set_errno(EVMSERR); + set_vaxc_errno(retsts); + break; + default: /* bail out */ + { _ckvmssts(retsts); } + } + } + } + + +void +_setsym(name,val,typestr="LOCAL") + SV * name + SV * val + char * typestr + CODE: + { + struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, + valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; + STRLEN slen; + int type; + unsigned long int retsts; + SETERRNO(0,SS$_NORMAL); + if (!name || !val) { + SETERRNO(EINVAL,LIB$_INVARG); + XSRETURN_UNDEF; + } + namdsc.dsc$a_pointer = SvPV(name,slen); + namdsc.dsc$w_length = (unsigned short int) slen; + valdsc.dsc$a_pointer = SvPV(val,slen); + valdsc.dsc$w_length = (unsigned short int) slen; + type = strNE(typestr,"GLOBAL") ? + LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM; + retsts = lib$set_symbol(&namdsc,&valdsc,&type); + if (retsts & 1) { XSRETURN_YES; } + else { + switch (retsts) { + case LIB$_AMBSYMDEF: /* user errors; set errno and return */ + case LIB$_INSCLIMEM: + case LIB$_INVSYMNAM: + case LIB$_NOCLI: + set_errno(EVMSERR); + set_vaxc_errno(retsts); + XSRETURN_NO; + break; /* NOTREACHED */ + default: /* bail out */ + { _ckvmssts(retsts); } + } + } + } + + +void +_delsym(name,typestr="LOCAL") + SV * name + char * typestr + CODE: + { + struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; + STRLEN slen; + int type; + unsigned long int retsts; + SETERRNO(0,SS$_NORMAL); + if (!name || !typestr) { + SETERRNO(EINVAL,LIB$_INVARG); + XSRETURN_UNDEF; + } + namdsc.dsc$a_pointer = SvPV(name,slen); + namdsc.dsc$w_length = (unsigned short int) slen; + type = strNE(typestr,"GLOBAL") ? + LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM; + retsts = lib$delete_symbol(&namdsc,&type); + if (retsts & 1) { XSRETURN_YES; } + else { + switch (retsts) { + case LIB$_INVSYMNAM: /* user errors; set errno and return */ + case LIB$_NOCLI: + case LIB$_NOSUCHSYM: + set_errno(EVMSERR); + set_vaxc_errno(retsts); + XSRETURN_NO; + break; /* NOTREACHED */ + default: /* bail out */ + { _ckvmssts(retsts); } + } + } + } + diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL b/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL new file mode 100644 index 00000000000..8e6f5bce40a --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL @@ -0,0 +1,3 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm' ); diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/test.pl b/gnu/usr.bin/perl/vms/ext/DCLsym/test.pl new file mode 100644 index 00000000000..57f2afbd20f --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/DCLsym/test.pl @@ -0,0 +1,41 @@ +print "1..15\n"; + +require VMS::DCLsym or die "failed 1\n"; +print "ok 1\n"; + +tie %syms, VMS::DCLsym or die "failed 2\n"; +print "ok 2\n"; + +$name = 'FOO_'.time(); +$syms{$name} = 'Perl_test'; +print +($! ? "(\$! = $!) not " : ''),"ok 3\n"; + +print +($syms{$name} eq 'Perl_test' ? '' : 'not '),"ok 4\n"; + +($val) = `Show Symbol $name` =~ /(\w+)"$/; +print +($val eq 'Perl_test' ? '' : 'not '),"ok 5\n"; + +while (($sym,$val) = each %syms) { + last if $sym eq $name && $val eq 'Perl_test'; +} +print +($sym ? '' : 'not '),"ok 6\n"; + +delete $syms{$name}; +print +($! ? "(\$! = $!) not " : ''),"ok 7\n"; + +print +(defined($syms{$name}) ? 'not ' : ''),"ok 8\n"; +undef %syms; + +$obj = new VMS::DCLsym 'GLOBAL'; +print +($obj ? '' : 'not '),"ok 9\n"; + +print +($obj->clearcache(0) ? '' : 'not '),"ok 10\n"; +print +($obj->clearcache(1) ? 'not ' : ''),"ok 11\n"; + +print +($obj->setsym($name,'Another_test') ? '' : 'not '),"ok 12\n"; + +($val,$tab) = $obj->getsym($name); +print +($val eq 'Another_test' && $tab eq 'GLOBAL' ? '' : 'not '),"ok 13\n"; + +print +($obj->delsym($name,'LOCAL') ? 'not ' : ''),"ok 14\n"; +print +($obj->delsym($name,'GLOBAL') ? '' : 'not '),"ok 15\n"; diff --git a/gnu/usr.bin/perl/vms/ext/XSSymSet.pm b/gnu/usr.bin/perl/vms/ext/XSSymSet.pm new file mode 100644 index 00000000000..868a303c01d --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/XSSymSet.pm @@ -0,0 +1,239 @@ +package ExtUtils::XSSymSet; + +use Carp qw( &carp ); +use strict; +use vars qw( $VERSION ); +$VERSION = '1.0'; + + +sub new { + my($pkg,$maxlen,$silent) = @_; + $maxlen ||= 31; + $silent ||= 0; + my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent }; + bless $obj, $pkg; +} + + +sub trimsym { + my($self,$name,$maxlen,$silent) = @_; + + unless (defined $maxlen) { + if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; } + $maxlen ||= 31; + } + unless (defined $silent) { + if (ref $self) { $silent ||= $self->{'__S!lent'}; } + $silent ||= 0; + } + return $name if (length $name <= $maxlen); + + my $trimmed = $name; + # First, just try to remove duplicated delimiters + $trimmed =~ s/__/_/g; + if (length $trimmed > $maxlen) { + # Next, all duplicated chars + $trimmed =~ s/(.)\1+/$1/g; + if (length $trimmed > $maxlen) { + my $squeezed = $trimmed; + my($xs,$prefix,$func) = $trimmed =~ /^(XS_)?(.*)_([^_]*)$/; + if (length $func <= 12) { # Try to preserve short function names + my $frac = int(length $prefix / (length $trimmed - $maxlen) + 0.5); + my $pat = '([^_])'; + if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; } + $prefix =~ s/$pat/$1/g; + $squeezed = "$xs$prefix" . "_$func"; + if (length $squeezed > $maxlen) { + $pat =~ s/A-Z//; + $prefix =~ s/$pat/$1/g; + $squeezed = "$xs$prefix" . "_$func"; + } + } + else { + my $frac = int(length $trimmed / (length $trimmed - $maxlen) + 0.5); + my $pat = '([^_])'; + if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; } + $squeezed = "$prefix$func"; + $squeezed =~ s/$pat/$1/g; + if (length "$xs$squeezed" > $maxlen) { + $pat =~ s/A-Z//; + $squeezed =~ s/$pat/$1/g; + } + $squeezed = "$xs$squeezed"; + } + if (length $squeezed <= $maxlen) { $trimmed = $squeezed; } + else { + my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5); + my $pat = '(.).{$frac}'; + $trimmed =~ s/$pat/$1/g; + } + } + } + carp "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent; + return $trimmed; +} + + +sub addsym { + my($self,$sym,$maxlen,$silent) = @_; + my $trimmed = $self->get_trimmed($sym); + + return $trimmed if defined $trimmed; + + $maxlen ||= $self->{'__M@xLen'} || 31; + $silent ||= $self->{'__S!lent'} || 0; + $trimmed = $self->trimsym($sym,$maxlen,1); + if (exists $self->{$trimmed}) { + my($i) = "00"; + $trimmed = $self->trimsym($sym,$maxlen-3,$silent); + while (exists $self->{"${trimmed}_$i"}) { $i++; } + carp "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t" + unless $silent; + $trimmed .= "_$i"; + } + elsif (not $silent and $trimmed ne $sym) { + carp "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t"; + } + $self->{$trimmed} = $sym; + $self->{'__N+Map'}->{$sym} = $trimmed; + $trimmed; +} + + +sub delsym { + my($self,$sym) = @_; + my $trimmed = $self->{'__N+Map'}->{$sym}; + if (defined $trimmed) { + delete $self->{'__N+Map'}->{$sym}; + delete $self->{$trimmed}; + } + $trimmed; +} + + +sub get_trimmed { + my($self,$sym) = @_; + $self->{'__N+Map'}->{$sym}; +} + + +sub get_orig { + my($self,$trimmed) = @_; + $self->{$trimmed}; +} + + +sub all_orig { (keys %{$_[0]->{'__N+Map'}}); } +sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); } + +__END__ + +=head1 NAME + +VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker + +=head1 SYNOPSIS + + use VMS::XSSymSet; + + $set = new VMS::XSSymSet; + while ($sym = make_symbol()) { $set->addsym($sym); } + foreach $safesym ($set->all_trimmed) { + print "Processing $safesym (derived from ",$self->get_orig($safesym),")\n"; + do_stuff($safesym); + } + + $safesym = VMS::XSSymSet->trimsym($onesym); + +=head1 DESCRIPTION + +Since the VMS linker distinguishes symbols based only on the first 31 +characters of their names, it is occasionally necessary to shorten +symbol names in order to avoid collisions. (This is especially true of +names generated by xsubpp, since prefixes generated by nested package +names can become quite long.) C<VMS::XSSymSet> provides functions to +shorten names in a consistent fashion, and to track a set of names to +insure that each is unique. While designed with F<xsubpp> in mind, it +may be used with any set of strings. + +This package supplies the following functions, all of which should be +called as methods. + +=over 4 + +=item new([$maxlen[,$silent]]) + +Creates an empty C<VMS::XSSymset> set of symbols. This function may be +called as a static method or via an existing object. If C<$maxlen> or +C<$silent> are specified, they are used as the defaults for maximum +name length and warning behavior in future calls to addsym() or +trimsym() via this object. + +=item addsym($name[,$maxlen[,$silent]]) + +Creates a symbol name from C<$name>, using the methods described +under trimsym(), which is unique in this set of symbols, and returns +the new name. C<$name> and its resultant are added to the set, and +any future calls to addsym() specifying the same C<$name> will return +the same result, regardless of the value of C<$maxlen> specified. +Unless C<$silent> is true, warnings are output if C<$name> had to be +trimmed or changed in order to avoid collision with an existing symbol +name. C<$maxlen> and C<$silent> default to the values specified when +this set of symbols was created. This method must be called via an +existing object. + +=item trimsym($name[,$maxlen[,$silent]]) + +Creates a symbol name C<$maxlen> or fewer characters long from +C<$name> and returns it. If C<$name> is too long, it first tries to +shorten it by removing duplicate characters, then by periodically +removing non-underscore characters, and finally, if necessary, by +periodically removing characters of any type. C<$maxlen> defaults +to 31. Unless C<$silent> is true, a warning is output if C<$name> +is altered in any way. This function may be called either as a +static method or via an existing object, but in the latter case no +check is made to insure that the resulting name is unique in the +set of symbols. + +=item delsym($name) + +Removes C<$name> from the set of symbols, where C<$name> is the +original symbol name passed previously to addsym(). If C<$name> +existed in the set of symbols, returns its "trimmed" equivalent, +otherwise returns C<undef>. This method must be called via an +existing object. + +=item get_orig($trimmed) + +Returns the original name which was trimmed to C<$trimmed> by a +previous call to addsym(), or C<undef> if C<$trimmed> does not +correspond to a member of this set of symbols. This method must be +called via an existing object. + +=item get_trimmed($name) + +Returns the trimmed name which was generated from C<$name> by a +previous call to addsym(), or C<undef> if C<$name> is not a member +of this set of symbols. This method must be called via an +existing object. + +=item all_orig() + +Returns a list containing all of the original symbol names +from this set. + +=item all_trimmed() + +Returns a list containing all of the trimmed symbol names +from this set. + +=back + +=head1 AUTHOR + +Charles Bailey E<lt>I<bailey@genetics.upenn.edu>E<gt> + +=head1 REVISION + +Last revised 14-Feb-1997, for Perl 5.004. + diff --git a/gnu/usr.bin/perl/vms/ext/filespec.t b/gnu/usr.bin/perl/vms/ext/filespec.t new file mode 100644 index 00000000000..6201a42dc69 --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/filespec.t @@ -0,0 +1,133 @@ +#!./perl + +BEGIN { unshift(@INC,'../lib') if -d '../lib'; } + +use VMS::Filespec; + +foreach (<DATA>) { + chomp; + s/\s*#.*//; + next if /^\s*$/; + push(@tests,$_); +} +print '1..',scalar(@tests)+3,"\n"; + +foreach $test (@tests) { + ($arg,$func,$expect) = split(/\t+/,$test); + $idx++; + $rslt = eval "$func('$arg')"; + if ($@) { print "not ok $idx : eval error: $@\n"; next; } + else { + if ($rslt ne $expect) { + print "not ok $idx : $func('$arg') expected |$expect|, got |$rslt|\n"; + } + else { print "ok $idx\n"; } + } +} + +if (rmsexpand('[]') eq "\U$ENV{DEFAULT}") { print 'ok ',++$idx,"\n"; } +else { + print 'not ok ', ++$idx, ": rmsexpand('[]') = |", rmsexpand('[]'), + "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n"; + print "# Note: This failure may have occurred because your default device\n"; + print "# was set using a non-concealed logical name. If this is the case,\n"; + print "# you will need to determine by inspection that the two resultant\n"; + print "# file specifications shwn above are in fact equivalent.\n"; +} +if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") { + print 'ok ', ++$idx, "\n"; +} +else { + print 'not ok ', ++$idx, ": rmsexpand('from.here') = |", + rmsexpand('from.here'), + "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n"; + print "# Note: This failure may have occurred because your default device\n"; + print "# was set using a non-concealed logical name. If this is the case,\n"; + print "# you will need to determine by inspection that the two resultant\n"; + print "# file specifications shwn above are in fact equivalent.\n"; +} +if (rmsexpand('from.here','cant:[get.there];2') eq + 'cant:[get.there]from.here;2') { print 'ok ',++$idx,"\n"; } +else { + print 'not ok ', ++$idx, ': expected |cant:[get.there]from.here;2|, got |', + rmsexpand('from.here','cant:[get.there];2'),"|\n"; +} + +__DATA__ + +# Basic VMS to Unix filespecs +some:[where.over]the.rainbow unixify /some/where/over/the.rainbow +[.some.where.over]the.rainbow unixify some/where/over/the.rainbow +[-.some.where.over]the.rainbow unixify ../some/where/over/the.rainbow +[.some.--.where.over]the.rainbow unixify some/../../where/over/the.rainbow +[.some...where.over]the.rainbow unixify some/.../where/over/the.rainbow +[...some.where.over]the.rainbow unixify .../some/where/over/the.rainbow +[.some.where.over...]the.rainbow unixify some/where/over/.../the.rainbow +[.some.where.over...] unixify some/where/over/.../ +[.some.where.over.-] unixify some/where/over/../ +[] unixify ./ +[-] unixify ../ +[--] unixify ../../ +[...] unixify .../ + +# and back again +/some/where/over/the.rainbow vmsify some:[where.over]the.rainbow +some/where/over/the.rainbow vmsify [.some.where.over]the.rainbow +../some/where/over/the.rainbow vmsify [-.some.where.over]the.rainbow +some/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow +.../some/where/over/the.rainbow vmsify [...some.where.over]the.rainbow +some/.../where/over/the.rainbow vmsify [.some...where.over]the.rainbow +/some/.../where/over/the.rainbow vmsify some:[...where.over]the.rainbow +some/where/... vmsify [.some.where...] +/where/... vmsify where:[...] +. vmsify [] +.. vmsify [-] +../.. vmsify [--] +.../ vmsify [...] + +# Fileifying directory specs +down:[the.garden.path] fileify down:[the.garden]path.dir;1 +[.down.the.garden.path] fileify [.down.the.garden]path.dir;1 +/down/the/garden/path fileify /down/the/garden/path.dir;1 +/down/the/garden/path/ fileify /down/the/garden/path.dir;1 +down/the/garden/path fileify down/the/garden/path.dir;1 +down:[the.garden]path fileify down:[the.garden]path.dir;1 +down:[the.garden]path. fileify # N.B. trailing . ==> null type +down:[the]garden.path fileify +/down/the/garden/path. fileify # N.B. trailing . ==> null type +/down/the/garden.path fileify + +# and pathifying them +down:[the.garden]path.dir;1 pathify down:[the.garden.path] +[.down.the.garden]path.dir pathify [.down.the.garden.path] +/down/the/garden/path.dir pathify /down/the/garden/path/ +down/the/garden/path.dir pathify down/the/garden/path/ +down:[the.garden]path pathify down:[the.garden.path] +down:[the.garden]path. pathify # N.B. trailing . ==> null type +down:[the]garden.path pathify +/down/the/garden/path. pathify # N.B. trailing . ==> null type +/down/the/garden.path pathify +down:[the.garden]path.dir;2 pathify #N.B. ;2 +path pathify path/ +/down/the/garden/. pathify /down/the/garden/./ +/down/the/garden/.. pathify /down/the/garden/../ +/down/the/garden/... pathify /down/the/garden/.../ +path.notdir pathify + +# Both VMS/Unix and file/path conversions +down:[the.garden]path.dir;1 unixpath /down/the/garden/path/ +/down/the/garden/path vmspath down:[the.garden.path] +down:[the.garden.path] unixpath /down/the/garden/path/ +down:[the.garden.path...] unixpath /down/the/garden/path/.../ +/down/the/garden/path.dir vmspath down:[the.garden.path] +[.down.the.garden]path.dir unixpath down/the/garden/path/ +down/the/garden/path vmspath [.down.the.garden.path] +path vmspath [.path] + +# Redundant characters in Unix paths +//some/where//over/../the.rainbow vmsify some:[where]the.rainbow +/some/where//over/./the.rainbow vmsify some:[where.over]the.rainbow +..//../ vmspath [--] +./././ vmspath [] +./../. vmsify [-] + diff --git a/gnu/usr.bin/perl/vms/ext/vmsish.pm b/gnu/usr.bin/perl/vms/ext/vmsish.pm new file mode 100644 index 00000000000..851d576e792 --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/vmsish.pm @@ -0,0 +1,76 @@ +package vmsish; + +=head1 NAME + +vmsish - Perl pragma to control VMS-specific language features + +=head1 SYNOPSIS + + use vmsish; + + use vmsish 'status'; # or '$?' + use vmsish 'exit'; + use vmsish 'time'; + + use vmsish; + no vmsish 'time'; + +=head1 DESCRIPTION + +If no import list is supplied, all possible VMS-specific features are +assumed. Currently, there are three VMS-specific features available: +'status' (a.k.a '$?'), 'exit', and 'time'. + +=over 6 + +=item C<vmsish status> + +This makes C<$?> and C<system> return the native VMS exit status +instead of emulating the POSIX exit status. + +=item C<vmsish exit> + +This makes C<exit 1> produce a successful exit (with status SS$_NORMAL), +instead of emulating UNIX exit(), which considers C<exit 1> to indicate +an error. As with the CRTL's exit() function, C<exit 0> is also mapped +to an exit status of SS$_NORMAL, and any other argument to exit() is +used directly as Perl's exit status. + +=item C<vmsish time> + +This makes all times relative to the local time zone, instead of the +default of Universal Time (a.k.a Greenwich Mean Time, or GMT). + +=back + +See L<perlmod/Pragmatic Modules>. + +=cut + +if ($^O ne 'VMS') { + require Carp; + Carp::croak("This isn't VMS"); +} + +sub bits { + my $bits = 0; + my $sememe; + foreach $sememe (@_) { + $bits |= 0x01000000, next if $sememe eq 'status' || $sememe eq '$?'; + $bits |= 0x02000000, next if $sememe eq 'exit'; + $bits |= 0x04000000, next if $sememe eq 'time'; + } + $bits; +} + +sub import { + shift; + $^H |= bits(@_ ? @_ : qw(status exit time)); +} + +sub unimport { + shift; + $^H &= ~ bits(@_ ? @_ : qw(status exit time)); +} + +1; diff --git a/gnu/usr.bin/perl/vms/ext/vmsish.t b/gnu/usr.bin/perl/vms/ext/vmsish.t new file mode 100644 index 00000000000..f68b3ac89c0 --- /dev/null +++ b/gnu/usr.bin/perl/vms/ext/vmsish.t @@ -0,0 +1,122 @@ + +BEGIN { unshift @INC, '[-.lib]'; } + +my $Invoke_Perl = qq(MCR $^X "-I[-.lib]"); + +print "1..16\n"; + +#========== vmsish status ========== +`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter. +if ($?) { print "not ok 1 # POSIX status is $?\n"; } +else { print "ok 1\n"; } +{ + use vmsish qw(status); + if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; } + else { print "ok 2\n"; } + { + no vmsish '$?'; # check unimport function + if ($?) { print "not ok 3 # POSIX status is $?\n"; } + else { print "ok 3\n"; } + } + # and lexical scoping + if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; } + else { print "ok 4\n"; } +} +if ($?) { print "not ok 5 # POSIX status is $?\n"; } +else { print "ok 5\n"; } +{ + use vmsish qw(exit); # check import function + if ($?) { print "not ok 6 # POSIX status is $?\n"; } + else { print "ok 6\n"; } +} + +#========== vmsish exit ========== +{ + use vmsish qw(status); + my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`; + if ($msg !~ /ABORT/) { + $msg =~ s/\n/\\n/g; # keep output on one line + print "not ok 7 # subprocess output: |$msg|\n"; + } + else { print "ok 7\n"; } + if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; } + else { print "ok 8\n"; } + + $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`; + if (length $msg) { + $msg =~ s/\n/\\n/g; # keep output on one line + print "not ok 9 # subprocess output: |$msg|\n"; + } + else { print "ok 9\n"; } + if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; } + else { print "ok 10\n"; } + + $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`; + if ($msg !~ /ABORT/) { + $msg =~ s/\n/\\n/g; # keep output on one line + print "not ok 11 # subprocess output: |$msg|\n"; + } + else { print "ok 11\n"; } + if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; } + else { print "ok 12\n"; } +} + + +#========== vmsish time ========== +{ + my($utctime, @utclocal, @utcgmtime, $utcmtime, + $vmstime, @vmslocal, @vmsgmtime, $vmsmtime, + $utcval, $vmaval, $offset); + # Make sure apparent local time isn't GMT + if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) { + $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; + $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600; + eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }"; + gmtime(0); # Force reset of tz offset + } + { + use vmsish qw(time); + $vmstime = time; + @vmslocal = localtime($vmstime); + @vmsgmtime = gmtime($vmstime); + $vmsmtime = (stat $0)[9]; + } + $utctime = time; + @utclocal = localtime($vmstime); + @utcgmtime = gmtime($vmstime); + $utcmtime = (stat $0)[9]; + + $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; + + # We allow lots of leeway (10 sec) difference for these tests, + # since it's unlikely local time will differ from UTC by so small + # an amount, and it renders the test resistant to delays from + # things like stat() on a file mounted over a slow network link. + if ($utctime - $vmstime + $offset > 10) { + print "not ok 13 # (time) UTC: $utctime VMS: $vmstime\n"; + } + else { print "ok 13\n"; } + + $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 + + $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; + $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + + $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; + if ($vmsval - $utcval + $offset > 10) { + print "not ok 14 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; + } + else { print "ok 14\n"; } + + $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + + $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; + $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + + $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; + if ($vmsval - $utcval + $offset > 10) { + print "not ok 15 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; + } + else { print "ok 15\n"; } + + if ($utcmtime - $vmsmtime + $offset > 10) { + print "not ok 16 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; + } + else { print "ok 16\n"; } +} diff --git a/gnu/usr.bin/perl/win32/Makefile b/gnu/usr.bin/perl/win32/Makefile new file mode 100644 index 00000000000..7a98f84c2cb --- /dev/null +++ b/gnu/usr.bin/perl/win32/Makefile @@ -0,0 +1,517 @@ +# +# Makefile to build perl on Windowns NT using Microsoft NMAKE. +# +# +# This is set up to build a perl.exe that runs off a shared library +# (perl.dll). Also makes individual DLLs for the XS extensions. +# + +# +# Set these to wherever you want "nmake install" to put your +# newly built perl. +INST_DRV=c: +INST_TOP=$(INST_DRV)\perl + +# +# uncomment next line if you are using Visual C++ 2.x +#CCTYPE=MSVC20 + +# +# uncomment next line if you want debug version of perl (big,slow) +#CFG=Debug + +# +# set the install locations of the compiler include/libraries +#CCHOME = f:\msvc20 +CCHOME = $(MSVCDIR) +CCINCDIR = $(CCHOME)\include +CCLIBDIR = $(CCHOME)\lib + +# +# set this to your email address (perl will guess a value from +# from your loginname and your hostname, which may not be right) +#EMAIL = + +##################### CHANGE THESE ONLY IF YOU MUST ##################### + +# +# Programs to compile, build .lib files and link +# + +CC=cl.exe +LINK32=link.exe +LIB32=$(LINK32) -lib +# +# Options +# +!IF "$(RUNTIME)" == "" +RUNTIME = -MD +!ENDIF +INCLUDES = -I.\include -I. -I.. +#PCHFLAGS = -Fp"$(INTDIR)/modules.pch" -YX +DEFINES = -DWIN32 -D_CONSOLE -DPERLDLL +SUBSYS = console + +!IF "$(RUNTIME)" == "-MD" +LIBC = msvcrt.lib +WINIOMAYBE = +!ELSE +LIBC = libcmt.lib +WINIOMAYBE = win32io.obj +!ENDIF + +!IF "$(CFG)" == "Debug" +! IF "$(CCTYPE)" == "MSVC20" +OPTIMIZE = -Od $(RUNTIME) -Z7 -D_DEBUG +! ELSE +OPTIMIZE = -Od $(RUNTIME)d -Z7 -D_DEBUG +! ENDIF +LINK_DBG = -debug -pdb:none +!ELSE +! IF "$(CCTYPE)" == "MSVC20" +OPTIMIZE = -Od $(RUNTIME) -DNDEBUG +! ELSE +OPTIMIZE = -Od $(RUNTIME) -DNDEBUG +! ENDIF +LINK_DBG = -release +!ENDIF + +# we don't add LIBC here, the compiler do it based on -MD/-MT +LIBFILES = oldnames.lib kernel32.lib user32.lib gdi32.lib \ + winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \ + oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \ + version.lib odbc32.lib odbccp32.lib + +CFLAGS = -nologo -W3 $(INCLUDES) $(DEFINES) $(PCHFLAGS) $(OPTIMIZE) +LINK_FLAGS = -nologo $(LIBFILES) $(LINK_DBG) -machine:I386 +OBJOUT_FLAG = -Fo + +#################### do not edit below this line ####################### +############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ############## + +# +# Rules +# +.SUFFIXES : +.SUFFIXES : .c .obj .dll .lib .exe + +.c.obj: + $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $< + +.obj.dll: + $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ + -out:$@ $(LINK_FLAGS) $< $(LIBPERL) + +# +INST_BIN=$(INST_TOP)\bin +INST_LIB=$(INST_TOP)\lib +INST_POD=$(INST_LIB)\pod +INST_HTML=$(INST_POD)\html +LIBDIR=..\lib +EXTDIR=..\ext +PODDIR=..\pod +EXTUTILSDIR=$(LIBDIR)\extutils + +# +# various targets +PERLIMPLIB=..\perl.lib +MINIPERL=..\miniperl.exe +PERLDLL=..\perl.dll +PERLEXE=..\perl.exe +GLOBEXE=..\perlglob.exe +CONFIGPM=..\lib\Config.pm +MINIMOD=..\lib\ExtUtils\Miniperl.pm + +PL2BAT=bin\pl2bat.pl +GLOBBAT = bin\perlglob.bat + +MAKE=nmake -nologo +CFGSH_TMPL = config.vc +CFGH_TMPL = config_H.vc +PERL95EXE=..\perl95.exe +XCOPY=xcopy /f /r /i /d +RCOPY=xcopy /f /r /i /e /d +NULL= + +# +# filenames given to xsubpp must have forward slashes (since it puts +# full pathnames in #line strings) +XSUBPP=..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp -C++ -prototypes + +CORE_C= ..\av.c \ + ..\deb.c \ + ..\doio.c \ + ..\doop.c \ + ..\dump.c \ + ..\globals.c \ + ..\gv.c \ + ..\hv.c \ + ..\mg.c \ + ..\op.c \ + ..\perl.c \ + ..\perlio.c \ + ..\perly.c \ + ..\pp.c \ + ..\pp_ctl.c \ + ..\pp_hot.c \ + ..\pp_sys.c \ + ..\regcomp.c \ + ..\regexec.c \ + ..\run.c \ + ..\scope.c \ + ..\sv.c \ + ..\taint.c \ + ..\toke.c \ + ..\universal.c \ + ..\util.c + +CORE_OBJ= ..\av.obj \ + ..\deb.obj \ + ..\doio.obj \ + ..\doop.obj \ + ..\dump.obj \ + ..\globals.obj \ + ..\gv.obj \ + ..\hv.obj \ + ..\mg.obj \ + ..\op.obj \ + ..\perl.obj \ + ..\perlio.obj \ + ..\perly.obj \ + ..\pp.obj \ + ..\pp_ctl.obj \ + ..\pp_hot.obj \ + ..\pp_sys.obj \ + ..\regcomp.obj \ + ..\regexec.obj \ + ..\run.obj \ + ..\scope.obj \ + ..\sv.obj \ + ..\taint.obj \ + ..\toke.obj \ + ..\universal.obj\ + ..\util.obj + +WIN32_C = perllib.c \ + win32.c \ + win32io.c \ + win32sck.c + +WIN32_OBJ = win32.obj \ + win32io.obj \ + win32sck.obj + +PERL95_OBJ = perl95.obj \ + win32mt.obj \ + win32iomt.obj \ + win32sckmt.obj + +DLL_OBJ = perllib.obj $(DYNALOADER).obj + +CORE_H = ..\av.h \ + ..\cop.h \ + ..\cv.h \ + ..\dosish.h \ + ..\embed.h \ + ..\form.h \ + ..\gv.h \ + ..\handy.h \ + ..\hv.h \ + ..\mg.h \ + ..\nostdio.h \ + ..\op.h \ + ..\opcode.h \ + ..\perl.h \ + ..\perlio.h \ + ..\perlsdio.h \ + ..\perlsfio.h \ + ..\perly.h \ + ..\pp.h \ + ..\proto.h \ + ..\regexp.h \ + ..\scope.h \ + ..\sv.h \ + ..\unixish.h \ + ..\util.h \ + ..\XSUB.h \ + .\config.h \ + ..\EXTERN.h \ + .\include\dirent.h \ + .\include\netdb.h \ + .\include\sys\socket.h \ + .\win32.h + +EXTENSIONS=DynaLoader Socket IO Fcntl Opcode SDBM_File + +DYNALOADER=$(EXTDIR)\DynaLoader\DynaLoader +SOCKET=$(EXTDIR)\Socket\Socket +FCNTL=$(EXTDIR)\Fcntl\Fcntl +OPCODE=$(EXTDIR)\Opcode\Opcode +SDBM_FILE=$(EXTDIR)\SDBM_File\SDBM_File +IO=$(EXTDIR)\IO\IO + +SOCKET_DLL=..\lib\auto\Socket\Socket.dll +FCNTL_DLL=..\lib\auto\Fcntl\Fcntl.dll +OPCODE_DLL=..\lib\auto\Opcode\Opcode.dll +SDBM_FILE_DLL=..\lib\auto\SDBM_File\SDBM_File.dll +IO_DLL=..\lib\auto\IO\IO.dll + +STATICLINKMODULES=DynaLoader +DYNALOADMODULES= \ + $(SOCKET_DLL) \ + $(FCNTL_DLL) \ + $(OPCODE_DLL) \ + $(SDBM_FILE_DLL)\ + $(IO_DLL) + +POD2HTML=$(PODDIR)\pod2html +POD2MAN=$(PODDIR)\pod2man +POD2LATEX=$(PODDIR)\pod2latex +POD2TEXT=$(PODDIR)\pod2text + +# +# Top targets +# + +all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT) + +$(DYNALOADER).obj : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c + +#------------------------------------------------------------ + +$(GLOBEXE): perlglob.obj + $(LINK32) $(LINK_FLAGS) -out:$@ -subsystem:$(SUBSYS) perlglob.obj setargv.obj + +$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL) + $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT) + +perlglob.obj : perlglob.c + +..\miniperlmain.obj : ..\miniperlmain.c $(CORE_H) + +config.w32 : $(CFGSH_TMPL) + copy $(CFGSH_TMPL) config.w32 + +.\config.h : $(CFGSH_TMPL) + -del /f config.h + copy $(CFGH_TMPL) config.h + +..\config.sh : config.w32 $(MINIPERL) config_sh.PL + $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ + "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ + "cf_email=$(EMAIL)" "libs=$(LIBFILES)" "incpath=$(CCINCDIR)" \ + "libpth=$(CCLIBDIR)" "libc=$(LIBC)" \ + config.w32 > ..\config.sh + +$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl + cd .. && miniperl configpm + if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) + $(XCOPY) ..\*.h ..\lib\CORE\*.* + $(XCOPY) *.h ..\lib\CORE\*.* + $(RCOPY) include ..\lib\CORE\*.* + $(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \ + RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM) + +$(MINIPERL) : ..\miniperlmain.obj $(CORE_OBJ) $(WIN32_OBJ) + $(LINK32) -subsystem:console -out:$@ @<< + $(LINK_FLAGS) ..\miniperlmain.obj $(CORE_OBJ) $(WIN32_OBJ) +<< + +$(WIN32_OBJ) : $(CORE_H) +$(CORE_OBJ) : $(CORE_H) +$(DLL_OBJ) : $(CORE_H) + +perldll.def : $(MINIPERL) $(CONFIGPM) + $(MINIPERL) -w makedef.pl $(CCTYPE) > perldll.def + +$(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) + $(LINK32) -dll -def:perldll.def -out:$@ @<< + $(LINK_FLAGS) $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) +<< + $(XCOPY) $(PERLIMPLIB) ..\lib\CORE + +perl.def : $(MINIPERL) makeperldef.pl + $(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def + +$(MINIMOD) : $(MINIPERL) ..\minimod.pl + cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm + +perlmain.c : runperl.c + copy runperl.c perlmain.c + +perlmain.obj : perlmain.c + $(CC) $(CFLAGS) -UPERLDLL -c perlmain.c + +$(PERLEXE): $(PERLDLL) $(CONFIGPM) perlmain.obj + $(LINK32) -subsystem:console -out:perl.exe $(LINK_FLAGS) \ + perlmain.obj $(WINIOMAYBE) $(PERLIMPLIB) + copy perl.exe $@ + del perl.exe + copy splittree.pl .. + $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" + attrib -r ..\t\*.* + copy test ..\t + +perl95.c : runperl.c + copy runperl.c perl95.c + +perl95.obj : perl95.c + $(CC) $(CFLAGS) -MT -UPERLDLL -c perl95.c + +win32iomt.obj : win32io.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32iomt.obj win32io.c + +win32sckmt.obj : win32sck.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c + +win32mt.obj : win32.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32mt.obj win32.c + +$(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) + $(LINK32) -subsystem:console -out:perl95.exe $(LINK_FLAGS) \ + $(PERL95_OBJ) $(PERLIMPLIB) + copy perl95.exe $@ + del perl95.exe + +$(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) + if not exist ..\lib\auto md ..\lib\auto + $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL) + cd $(EXTDIR)\$(*B) + $(XSUBPP) dl_win32.xs > $(*B).c + cd ..\..\win32 + +$(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs + copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs + +$(IO_DLL): $(PERLEXE) $(CONFIGPM) $(IO).xs + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + +$(SDBM_FILE_DLL) : $(PERLEXE) $(SDBM_FILE).xs + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + +$(FCNTL_DLL): $(PERLEXE) $(FCNTL).xs + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + +$(OPCODE_DLL): $(PERLEXE) $(OPCODE).xs + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + +$(SOCKET_DLL): $(SOCKET).xs $(PERLEXE) + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + +doc: $(PERLEXE) + cd ..\pod + $(MAKE) -f ..\win32\pod.mak checkpods pod2html pod2latex \ + pod2man pod2text + $(XCOPY) *.bat ..\win32\bin\*.* + cd ..\win32 + copy ..\README.win32 ..\pod\perlwin32.pod + $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ + --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML::=|)" \ + --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse + +utils: $(PERLEXE) + cd ..\utils + nmake PERL=$(MINIPERL) + $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph + $(PERLEXE) ..\win32\$(PL2BAT) h2xs perldoc pstruct + $(XCOPY) *.bat ..\win32\bin\*.* + cd ..\win32 + $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ + bin\pl2bat.pl + +distclean: clean + -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \ + $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD) + -del /f *.def *.map + -del /f $(SOCKET_DLL) $(IO_DLL) $(SDBM_FILE_DLL) $(FCNTL_DLL) \ + $(OPCODE_DLL) + -del /f $(SOCKET).c $(IO).c $(SDBM_FILE).c $(FCNTL).c $(OPCODE).c \ + $(DYNALOADER).c + -del /f $(PODDIR)\*.html + -del /f $(PODDIR)\*.bat + -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c \ + config.h.new perl95.c + -del /f bin\*.bat + -rmdir /s /q ..\lib\auto + -rmdir /s /q ..\lib\CORE + cd $(EXTDIR) + -del /s *.lib *.def *.map *.bs Makefile *.obj pm_to_blib + cd ..\win32 + +install : all doc utils + if not exist $(INST_TOP) mkdir $(INST_TOP) + echo I $(INST_TOP) L $(LIBDIR) + $(XCOPY) $(PERLEXE) $(INST_BIN)\*.* + $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* + $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* + $(XCOPY) $(PERLDLL) $(INST_BIN)\*.* + $(XCOPY) bin\*.bat $(INST_BIN)\*.* + $(RCOPY) ..\lib $(INST_LIB)\*.* + $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* + $(XCOPY) ..\pod\*.pod $(INST_POD)\*.* + $(RCOPY) html\*.* $(INST_HTML)\*.* + +inst_lib : $(CONFIGPM) + copy splittree.pl .. + $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" + $(RCOPY) ..\lib $(INST_LIB)\*.* + +minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) + $(XCOPY) $(MINIPERL) ..\t\perl.exe + $(XCOPY) $(GLOBEXE) ..\t\$(NULL) + attrib -r ..\t\*.* + copy test ..\t + cd ..\t + $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t + cd ..\win32 + +test-prep : all + $(XCOPY) $(PERLEXE) ..\t\$(NULL) + $(XCOPY) $(PERLDLL) ..\t\$(NULL) + $(XCOPY) $(GLOBEXE) ..\t\$(NULL) + +test : test-prep + cd ..\t + $(PERLEXE) -I..\lib harness + cd ..\win32 + +test-notty : test-prep + set PERL_SKIP_TTY_TEST=1 + cd ..\t + $(PERLEXE) -I..\lib harness + cd ..\win32 + +clean : + -@erase miniperlmain.obj + -@erase $(MINIPERL) + -@erase perlglob.obj + -@erase perlmain.obj + -@erase config.w32 + -@erase /f config.h + -@erase $(GLOBEXE) + -@erase $(PERLEXE) + -@erase $(PERLDLL) + -@erase $(CORE_OBJ) + -@erase $(WIN32_OBJ) + -@erase $(DLL_OBJ) + -@erase ..\*.obj ..\*.lib ..\*.exp *.obj *.lib *.exp + -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat + -@erase *.ilk + -@erase *.pdb + + diff --git a/gnu/usr.bin/perl/win32/TEST b/gnu/usr.bin/perl/win32/TEST new file mode 100644 index 00000000000..1bda4ef7930 --- /dev/null +++ b/gnu/usr.bin/perl/win32/TEST @@ -0,0 +1,149 @@ +#!./perl + +# Last change: Fri Jan 10 09:57:03 WET 1997 + +# This is written in a peculiar style, since we're trying to avoid +# most of the constructs we'll be testing for. + +$| = 1; + +if ($ARGV[0] eq '-v') { + $verbose = 1; + shift; +} + +chdir 't' if -f 't/TEST'; + +die "You need to run \"make test\" first to set things up.\n" + unless -e 'perl' or -e 'perl.exe'; + +$ENV{EMXSHELL} = 'sh'; # For OS/2 + +if ($ARGV[0] eq '') { + push( @ARGV, `dir/s/b base` ); + push( @ARGV, `dir/s/b comp` ); + push( @ARGV, `dir/s/b cmd` ); + push( @ARGV, `dir/s/b io` ); + push( @ARGV, `dir/s/b op` ); + push( @ARGV, `dir/s/b pragma` ); + push( @ARGV, `dir/s/b lib` ); + + grep( chomp, @ARGV ); + @ARGV = grep( /\.t$/, @ARGV ); + grep( s/.*t\\//, @ARGV ); +# @ARGV = split(/[ \n]/, +# `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); +} else { + +@ARGV = map(glob($_),@ARGV); + +} + +if ($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'qnx' || 1) { + $sharpbang = 0; +} +else { + open(CONFIG, "../config.sh"); + while (<CONFIG>) { + if (/sharpbang='(.*)'/) { + $sharpbang = ($1 eq '#!'); + last; + } + } + close(CONFIG); +} + +$bad = 0; +$good = 0; +$total = @ARGV; +while ($test = shift) { + if ($test =~ /^$/) { + next; + } + $te = $test; + chop($te); + print "$te" . '.' x (18 - length($te)); + if ($sharpbang) { + open(results,"./$test |") || (print "can't run.\n"); + } else { + open(script,"$test") || die "Can't run $test.\n"; + $_ = <script>; + close(script); + if (/#!..perl(.*)/) { + $switch = $1; + if ($^O eq 'VMS') { + # Must protect uppercase switches with "" on command line + $switch =~ s/-([A-Z]\S*)/"-$1"/g; + } + } else { + $switch = ''; + } + open(results,"perl$switch $test |") || (print "can't run.\n"); + } + $ok = 0; + $next = 0; + while (<results>) { + if (/^$/) { next;}; + if ($verbose) { + print $_; + } + unless (/^#/) { + if (/^1\.\.([0-9]+)/) { + $max = $1; + $totmax += $max; + $files += 1; + $next = 1; + $ok = 1; + } else { + $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; + if (/^ok (.*)/ && $1 == $next) { + $next = $next + 1; + } else { + $ok = 0; + } + } + } + } + $next = $next - 1; + if ($ok && $next == $max) { + if ($max) { + print "ok\n"; + $good = $good + 1; + } else { + print "skipping test on this platform\n"; + $files -= 1; + } + } else { + $next += 1; + print "FAILED on test $next\n"; + $bad = $bad + 1; + $_ = $test; + if (/^base/) { + die "Failed a basic test--cannot continue.\n"; + } + } +} + +if ($bad == 0) { + if ($ok) { + print "All tests successful.\n"; + } else { + die "FAILED--no tests were run for some reason.\n"; + } +} else { + $pct = sprintf("%.2f", $good / $total * 100); + if ($bad == 1) { + warn "Failed 1 test script out of $total, $pct% okay.\n"; + } else { + warn "Failed $bad test scripts out of $total, $pct% okay.\n"; + } + warn <<'SHRDLU'; + ### Since not all tests were successful, you may want to run some + ### of them individually and examine any diagnostic messages they + ### produce. See the INSTALL document's section on "make test". +SHRDLU +} +($user,$sys,$cuser,$csys) = times; +print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", + $user,$sys,$cuser,$csys,$files,$totmax); +exit $bad != 0; diff --git a/gnu/usr.bin/perl/win32/autosplit.pl b/gnu/usr.bin/perl/win32/autosplit.pl new file mode 100644 index 00000000000..26ce2c358ce --- /dev/null +++ b/gnu/usr.bin/perl/win32/autosplit.pl @@ -0,0 +1,3 @@ +use AutoSplit; + +autosplit($ARGV[0], $ARGV[1], 0, 1, 1); diff --git a/gnu/usr.bin/perl/win32/bin/network.pl b/gnu/usr.bin/perl/win32/bin/network.pl new file mode 100644 index 00000000000..f49045333d9 --- /dev/null +++ b/gnu/usr.bin/perl/win32/bin/network.pl @@ -0,0 +1,211 @@ +## +## Jeffrey Friedl (jfriedl@omron.co.jp) +## Copyri.... ah hell, just take it. +## +## July 1994 +## +package network; +$version = "950311.5"; + +## version 950311.5 -- turned off warnings when requiring 'socket.ph'; +## version 941028.4 -- some changes to quiet perl5 warnings. +## version 940826.3 -- added check for "socket.ph", and alternate use of +## socket STREAM value for SunOS5.x +## + +## BLURB: +## A few simple and easy-to-use routines to make internet connections. +## Similar to "chat2.pl" (but actually commented, and a bit more portable). +## Should work even on SunOS5.x. +## + +##> +## +## connect_to() -- make an internet connection to a server. +## +## Two uses: +## $error = &network'connect_to(*FILEHANDLE, $fromsockaddr, $tosockaddr) +## $error = &network'connect_to(*FILEHANDLE, $hostname, $portnum) +## +## Makes the given connection and returns an error string, or undef if +## no error. +## +## In the first form, FROMSOCKADDR and TOSOCKADDR are of the form returned +## by SOCKET'GET_ADDR and SOCKET'MY_ADDR. +## +##< +sub connect_to +{ + local(*FD, $arg1, $arg2) = @_; + local($from, $to) = ($arg1, $arg2); ## for one interpretation. + local($host, $port) = ($arg1, $arg2); ## for the other + + if (defined($to) && length($from)==16 && length($to)==16) { + ## ok just as is + } elsif (defined($host)) { + $to = &get_addr($host, $port); + return qq/unknown address "$host"/ unless defined $to; + $from = &my_addr; + } else { + return "unknown arguments to network'connect_to"; + } + + return "connect_to failed (socket: $!)" unless &my_inet_socket(*FD); + return "connect_to failed (bind: $!)" unless bind(FD, $from); + return "connect_to failed (connect: $!)" unless connect(FD, $to); + local($old) = select(FD); $| = 1; select($old); + undef; +} + + + +##> +## +## listen_at() - used by a server to indicate that it will accept requests +## at the port number given. +## +## Used as +## $error = &network'listen_at(*LISTEN, $portnumber); +## (returns undef upon success) +## +## You can then do something like +## $addr = accept(REMOTE, LISTEN); +## print "contact from ", &network'addr_to_ascii($addr), ".\n"; +## while (<REMOTE>) { +## .... process request.... +## } +## close(REMOTE); +## +##< +sub listen_at +{ + local(*FD, $port) = @_; + local($empty) = pack('S n a4 x8', 2 ,$port, "\0\0\0\0"); + return "listen_for failed (socket: $!)" unless &my_inet_socket(*FD); + return "listen_for failed (bind: $!)" unless bind(FD, $empty); + return "listen_for failed (listen: $!)" unless listen(FD, 5); + local($old) = select(FD); $| = 1; select($old); + undef; +} + + +##> +## +## Given an internal packed internet address (as returned by &connect_to +## or &get_addr), return a printable ``1.2.3.4'' version. +## +##< +sub addr_to_ascii +{ + local($addr) = @_; + return "bad arg" if length $addr != 16; + return join('.', unpack("CCCC", (unpack('S n a4 x8', $addr))[2])); +} + +## +## +## Given a host and a port name, returns the packed socket addresss. +## Mostly for internal use. +## +## +sub get_addr +{ + local($host, $port) = @_; + return $addr{$host,$port} if defined $addr{$host,$port}; + local($addr); + + if ($host =~ m/^\d+\.\d+\.\d+\.\d+$/) + { + $addr = pack("C4", split(/\./, $host)); + } + elsif ($addr = (gethostbyname($host))[4], !defined $addr) + { + local(@lookup) = `nslookup $host 2>&1`; + if (@lookup) + { + local($lookup) = join('', @lookup[2 .. $#lookup]); + if ($lookup =~ m/^Address:\s*(\d+\.\d+\.\d+\.\d+)/) { + $addr = pack("C4", split(/\./, $1)); + } + } + if (!defined $addr) { + ## warn "$host: SOL, dude\n"; + return undef; + } + } + $addr{$host,$port} = pack('S n a4 x8', 2 ,$port, $addr); +} + + +## +## my_addr() +## Returns the packed socket address of the local host (port 0) +## Mostly for internal use. +## +## +sub my_addr +{ + local(@x) = gethostbyname('localhost'); + local(@y) = gethostbyname($x[0]); +# local($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($x[0]); +# local(@bytes) = unpack("C4",$addrs[0]); +# return pack('S n a4 x8', 2 ,0, $addr); + return pack('S n a4 x8', 2 ,0, $y[4]); +} + + +## +## my_inet_socket(*FD); +## +## Local routine to do socket(PF_INET, SOCK_STREAM, AF_NS). +## Takes care of figuring out the proper values for the args. Hopefully. +## +## Returns the same value as 'socket'. +## +sub my_inet_socket +{ + local(*FD) = @_; + local($socket); + + if (!defined $socket_values_queried) + { + ## try to load some "socket.ph" + if (!defined &main'_SYS_SOCKET_H_) { + eval 'package main; + local($^W) = 0; + require("sys/socket.ph")||require("socket.ph");'; + } + + ## we'll use "the regular defaults" if for PF_INET and AF_NS if unknown + $PF_INET = defined &main'PF_INET ? &main'PF_INET : 2; + $AF_NS = defined &main'AF_NS ? &main'AF_NS : 6; + $SOCK_STREAM = &main'SOCK_STREAM if defined &main'SOCK_STREAM; + + $socket_values_queried = 1; + } + + if (defined $SOCK_STREAM) { + $socket = socket(FD, $PF_INET, $SOCK_STREAM, $AF_NS); + } else { + ## + ## We'll try the "regular default" of 1. If that returns a + ## "not supported" error, we'll try 2, which SunOS5.x uses. + ## + $socket = socket(FD, $PF_INET, 1, $AF_NS); + if ($socket) { + $SOCK_STREAM = 1; ## got it. + } elsif ($! =~ m/not supported/i) { + ## we'll just assume from now on that it's 2. + $socket = socket(FD, $PF_INET, $SOCK_STREAM = 2, $AF_NS); + } + } + $socket; +} + +## This here just to quiet -w warnings. +sub dummy { + 1 || $version || &dummy; +} + +1; +__END__ diff --git a/gnu/usr.bin/perl/win32/bin/pl2bat.pl b/gnu/usr.bin/perl/win32/bin/pl2bat.pl new file mode 100644 index 00000000000..73ae87164da --- /dev/null +++ b/gnu/usr.bin/perl/win32/bin/pl2bat.pl @@ -0,0 +1,154 @@ +#!perl -w +require 5; +use Getopt::Std; + +$0 =~ s|.*[/\\]||; + +my $usage = <<EOT; +Usage: $0 [-h] [-a argstring] [-s stripsuffix] [files] + -a argstring arguments to invoke perl with in generated file + Defaults to "-x -S %0 %*" on WindowsNT, + "-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9" otherwise + -s stripsuffix strip this suffix from file before appending ".bat" + Not case-sensitive + Can be a regex if it begins with `/' + Defaults to "/\.pl/" + -h show this help +EOT + +my %OPT = (); +warn($usage), exit(0) if !getopts('ha:s:',\%OPT) or $OPT{'h'}; +$OPT{'a'} = ($^O eq 'MSWin32' and &Win32::IsWinNT + ? '-x -S %0 %*' + : '-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9') + unless exists $OPT{'a'}; +$OPT{'s'} = '.pl' unless exists $OPT{'s'}; +$OPT{'s'} = ($OPT{'s'} =~ m|^/([^/]*)| ? $1 : "\Q$OPT{'s'}\E"); + +(my $head = <<EOT) =~ s/^\t//gm; + \@rem = '--*-Perl-*-- + \@echo off + perl $OPT{'a'} + goto endofperl + \@rem '; +EOT +my $headlines = 2 + ($head =~ tr/\n/\n/); +my $tail = "__END__\n:endofperl\n"; + +@ARGV = ('-') unless @ARGV; + +process(@ARGV); + +sub process { + LOOP: + foreach ( @_ ) { + my $myhead = $head; + my $linedone = 0; + my $linenum = $headlines; + my $line; + open( FILE, $_ ) or die "$0: Can't open $_: $!"; + @file = <FILE>; + foreach $line ( @file ) { + $linenum++; + if ( $line =~ /^:endofperl/) { + warn "$0: $_ has already been converted to a batch file!\n"; + next LOOP; + } + if ( not $linedone and $line =~ /^#!.*perl/ ) { + $line .= "#line $linenum\n"; + $linedone++; + } + } + close( FILE ); + s/$OPT{'s'}$//oi; + $_ .= '.bat' unless /\.bat$/i or /^-$/; + open( FILE, ">$_" ) or die "Can't open $_: $!"; + print FILE $myhead; + print FILE "#!perl\n#line " . ($headlines+1) . "\n" unless $linedone; + print FILE @file, $tail; + close( FILE ); + } +} +__END__ + +=head1 NAME + +pl2bat - wrap perl code into a batch file + +=head1 SYNOPSIS + +B<pl2bat> [B<-h>] S<[B<-a> I<argstring>]> S<[B<-s> I<stripsuffix>]> [files] + +=head1 DESCRIPTION + +This utility converts a perl script into a batch file that can be +executed on DOS-like operating systems. + +Note that by default, the ".pl" suffix will be stripped before adding +a ".bat" suffix to the supplied file names. This can be controlled +with the C<-s> option. + +The default behavior on WindowsNT is to generate a batch file that +uses the C<%*> construct to refer to all the command line arguments +that were given to it, so you'll need to make sure that works on your +variant of the command shell. It is known to work in the cmd.exe shell +under WindowsNT. 4DOS/NT users will want to put a C<ParameterChar = *> +line in their initialization file, or execute C<setdos /p*> in +the shell startup file. On Windows95 and other platforms a nine +argument limit is imposed on command-line arguments given to the +generated batch file, since they may not support C<%*> in batch files. +This can be overridden using the C<-a> option. + +=head1 OPTIONS + +=over 8 + +=item B<-a> I<argstring> + +Arguments to invoke perl with in generated batch file. Defaults to +S<"-x -S %0 %*"> on WindowsNT, S<"-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9"> +on other platforms. + +=item B<-s> I<stripsuffix> + +Strip a suffix string from file name before appending a ".bat" +suffix. The suffix is not case-sensitive. It can be a regex if it +begins with `/' (the trailing '/' being optional. Defaults to ".pl". + +=item B<-h> + +Show command line usage. + +=back + +=head1 EXAMPLES + + C:\> pl2bat foo.pl bar.PM + [..creates foo.bat, bar.PM.bat..] + + C:\> pl2bat -s "/\.pl|\.pm/" foo.pl bar.PM + [..creates foo.bat, bar.bat..] + + C:\> pl2bat < somefile > another.bat + + C:\> pl2bat > another.bat + print scalar reverse "rekcah lrep rehtona tsuj\n"; + ^Z + [..another.bat is now a certified japh application..] + +=head1 BUGS + +C<$0> will contain the full name, including the ".bat" suffix +when the generated batch file runs. If you don't like this, +see runperl.bat for an alternative way to invoke perl scripts. + +Default behavior is to invoke Perl with the -S flag, so Perl will +search the PATH to find the script. This may have undesirable +effects. + +=head1 SEE ALSO + +perl, perlwin32, runperl.bat + +=cut + diff --git a/gnu/usr.bin/perl/win32/bin/runperl.pl b/gnu/usr.bin/perl/win32/bin/runperl.pl new file mode 100644 index 00000000000..95b33f9342d --- /dev/null +++ b/gnu/usr.bin/perl/win32/bin/runperl.pl @@ -0,0 +1,67 @@ +#!perl -w +$0 =~ s|\.bat||i; +unless (-f $0) { + $0 =~ s|.*[/\\]||; + for (".", split ';', $ENV{PATH}) { + $_ = "." if $_ eq ""; + $0 = "$_/$0" , goto doit if -f "$_/$0"; + } + die "`$0' not found.\n"; +} +doit: exec "perl", "-x", $0, @ARGV; +die "Failed to exec `$0': $!"; +__END__ + +=head1 NAME + +runperl.bat - "universal" batch file to run perl scripts + +=head1 SYNOPSIS + + C:\> copy runperl.bat foo.bat + C:\> foo + [..runs the perl script `foo'..] + + C:\> foo.bat + [..runs the perl script `foo'..] + + +=head1 DESCRIPTION + +This file can be copied to any file name ending in the ".bat" suffix. +When executed on a DOS-like operating system, it will invoke the perl +script of the same name, but without the ".bat" suffix. It will +look for the script in the same directory as itself, and then in +the current directory, and then search the directories in your PATH. + +It relies on the C<exec()> operator, so you will need to make sure +that works in your perl. + +This method of invoking perl scripts has some advantages over +batch-file wrappers like C<pl2bat.bat>: it avoids duplication +of all the code; it ensures C<$0> contains the same name as the +executing file, without any egregious ".bat" suffix; it allows +you to separate your perl scripts from the wrapper used to +run them; since the wrapper is generic, you can use symbolic +links to simply link to C<runperl.bat>, if you are serving your +files on a filesystem that supports that. + +On the other hand, if the batch file is invoked with the ".bat" +suffix, it does an extra C<exec()>. This may be a performance +issue. You can avoid this by running it without specifying +the ".bat" suffix. + +Perl is invoked with the -x flag, so the script must contain +a C<#!perl> line. Any flags found on that line will be honored. + +=head1 BUGS + +Perl is invoked with the -S flag, so it will search the PATH to find +the script. This may have undesirable effects. + +=head1 SEE ALSO + +perl, perlwin32, pl2bat.bat + +=cut + diff --git a/gnu/usr.bin/perl/win32/bin/search.pl b/gnu/usr.bin/perl/win32/bin/search.pl new file mode 100644 index 00000000000..b63f7353aff --- /dev/null +++ b/gnu/usr.bin/perl/win32/bin/search.pl @@ -0,0 +1,1865 @@ +#!/usr/local/bin/perl -w +'di'; +'ig00'; +############################################################################## +## +## search +## +## Jeffrey Friedl (jfriedl@omron.co.jp), Dec 1994. +## Copyright 19.... ah hell, just take it. +## +## BLURB: +## A combo of find and grep -- more or less do a 'grep' on a whole +## directory tree. Fast, with lots of options. Much more powerful than +## the simple "find ... | xargs grep ....". Has a full man page. +## Powerfully customizable. +## +## This file is big, but mostly comments and man page. +## +## See man page for usage info. +## Return value: 2=error, 1=nothing found, 0=something found. +## + +$version = "950918.5"; +## +## "950918.5"; +## Changed all 'sysread' to 'read' because Linux perl's don't seem +## to like sysread() +## +## "941227.4"; +## Added -n, -u +## +## "941222.3" +## Added -nice (due to Lionel Cons <Lionel.Cons@cern.ch>) +## Removed any leading "./" from name. +## Added default flags for ~/.search, including TTY, -nice, -list, etc. +## Program name now has path removed when printed in diagnostics. +## Added simple tilde-expansion to -dir arg. +## Added -dskip, etc. Fixed -iregex bug. +## Changed -dir to be additive, adding -ddir. +## Now screen out devices, pipes, and sockets. +## More tidying and lots of expanding of the man page +## +## +## "941217.2"; +## initial release. + +$stripped=0; + +&init; +$rc_file = join('/', $ENV{'HOME'}, ".search"); + +&check_args; + +## Make sure we've got a regex. +## Don't need one if -find or -showrc was specified. +$!=2, die "expecting regex arguments.\n" + if $FIND_ONLY == 0 && $showrc == 0 && @ARGV == 0; + +&prepare_to_search($rc_file); + +&import_program if !defined &dodir; ## BIG key to speed. + +## do search while there are directories to be done. +&dodir(shift(@todo)) while @todo; + +&clear_message if $VERBOSE && $STDERR_IS_TTY; +exit($retval); +############################################################################### + +sub init +{ + ## initialize variables that might be reset by command-line args + $DOREP=0; ## set true by -dorep (redo multi-hardlink files) + $DO_SORT=0; ## set by -sort (sort files in a dir before checking) + $FIND_ONLY=0; ## set by -find (don't search files) + $LIST_ONLY=0; ## set true by -l (list filenames only) + $NEWER=0; ## set by -newer, "-mtime -###" + $NICE=0; ## set by -nice (print human-readable output) + $NOLINKS=0; ## set true by -nolinks (don't follow symlinks) + $OLDER=0; ## set by -older, "-mtime ###" + $PREPEND_FILENAME=1; ## set false by -h (don't prefix lines with filename) + $REPORT_LINENUM=0; ## set true by -n (show line numbers) + $VERBOSE=0; ## set to a value by -v, -vv, etc. (verbose messages) + $WHY=0; ## set true by -why, -vvv+ (report why skipped) + $XDEV=0; ## set true by -xdev (stay on one filesystem) + $all=0; ## set true by -all (don't skip many kinds of files) + $iflag = ''; ## set to 'i' by -i (ignore case); + $norc=0; ## set by -norc (don't load rc file) + $showrc=0; ## set by -showrc (show what happens with rc file) + $underlineOK=0; ## set true by -u (watch for underline stuff) + $words=0; ## set true by -w (match whole-words only) + $DELAY=0; ## inter-file delay (seconds) + $retval=1; ## will set to 0 if we find anything. + + ## various elements of stat() that we might access + $STAT_DEV = 1; + $STAT_INODE = 2; + $STAT_MTIME = 9; + + $VV_PRINT_COUNT = 50; ## with -vv, print every VV_PRINT_COUNT files, or... + $VV_SIZE = 1024*1024; ## ...every VV_SIZE bytes searched + $vv_print = $vv_size = 0; ## running totals. + + ## set default options, in case the rc file wants them + $opt{'TTY'}= 1 if -t STDOUT; + + ## want to know this for debugging message stuff + $STDERR_IS_TTY = -t STDERR ? 1 : 0; + $STDERR_SCREWS_STDOUT = ($STDERR_IS_TTY && -t STDOUT) ? 1 : 0; + + $0 =~ s,.*/,,; ## clean up $0 for any diagnostics we'll be printing. +} + +## +## Check arguments. +## +sub check_args +{ + while (@ARGV && $ARGV[0] =~ m/^-/) + { + $arg = shift(@ARGV); + + if ($arg eq '-version' || ($VERBOSE && $arg eq '-help')) { + print qq/Jeffrey's file search, version "$version".\n/; + exit(0) unless $arg eq '-help'; + } + if ($arg eq '-help') { + print <<INLINE_LITERAL_TEXT; +usage: $0 [options] [-e] [PerlRegex ....] +OPTIONS TELLING *WHERE* TO SEARCH: + -dir DIR start search at the named directory (default is current dir). + -xdev stay on starting file system. + -sort sort the files in each directory before processing. + -nolinks don't follow symbolic links. +OPTIONS TELLING WHICH FILES TO EVEN CONSIDER: + -mtime # consider files modified > # days ago (-# for < # days old) + -newer FILE consider files modified more recently than FILE (also -older) + -name GLOB consider files whose name matches pattern (also -regex). + -skip GLOB opposite of -name: identifies files to not consider. + -path GLOB like -name, but for files whose whole path is described. + -dpath/-dregex/-dskip versions for selecting or pruning directories. + -all don't skip any files marked to be skipped by the startup file. + -x<SPECIAL> (see manual, and/or try -showrc). + -why report why a file isn't checked (also implied by -vvvv). +OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED: + -f | -find just list files (PerlRegex ignored). Default is to grep them. + -ff | -ffind Does a faster -find (implies -find -all -dorep) +OPTIONS CONTROLLING HOW THE SEARCH IS DONE (AND WHAT IS PRINTED): + -l | -list only list files with matches, not the lines themselves. + -nice | -nnice print more "human readable" output. + -n prefix each output line with its line number in the file. + -h don't prefix output lines with file name. + -u also look "inside" manpage-style underlined text + -i do case-insensitive searching. + -w match words only (as defined by perl's \\b). +OTHER OPTIONS: + -v, -vv, -vvv various levels of message verbosity. + -e end of options (in case a regex looks like an option). + -showrc show what the rc file sets, then exit. + -norc don't load the rc file. + -dorep check files with multiple hard links multiple times. +INLINE_LITERAL_TEXT + print "Use -v -help for more verbose help.\n" unless $VERBOSE; + print "This script file is also a man page.\n" unless $stripped; + print <<INLINE_LITERAL_TEXT if $VERBOSE; + +If -f (or -find) given, PerlRegex is optional and ignored. +Otherwise, will search for files with lines matching any of the given regexes. + +Combining things like -name and -mtime implies boolean AND. +However, duplicating things (such as -name '*.c' -name '*.txt') implies OR. + +-mtime may be given floating point (i.e. 1.5 is a day and a half). +-iskip/-idskip/-ipath/... etc are case-insensitive versions. + +If any letter in -newer/-older is upper case, "or equal" is +inserted into the test. + +You can always find the latest version on the World Wide Web in + http://www.wg.omron.co.jp/~jfriedl/perl/ +INLINE_LITERAL_TEXT + exit(0); + } + $DOREP=1, next if $arg eq '-dorep'; ## do repeats + $DO_SORT=1, next if $arg eq '-sort'; ## sort files + $NOLINKS=1, next if $arg eq '-nolinks'; ## no sym. links + $PREPEND_FILENAME=0, next if $arg eq '-h'; ## no filename prefix + $REPORT_LINENUM=1, next if $arg eq '-n'; ## show line numbers + $WHY=1, next if $arg eq '-why'; ## tell why skipped + $XDEV=1, next if $arg eq '-xdev'; ## don't leave F.S. + $all=1,$opt{'-all'}=1,next if $arg eq '-all'; ## don't skip *.Z, etc + $iflag='i', next if $arg eq '-i'; ## ignore case + $norc=1, next if $arg eq '-norc'; ## don't load rc file + $showrc=1, next if $arg eq '-showrc'; ## show rc file + $underlineOK=1, next if $arg eq '-u'; ## look throuh underln. + $words=1, next if $arg eq '-w'; ## match "words" only + &strip if $arg eq '-strip'; ## dump this program + last if $arg eq '-e'; + $DELAY=$1, next if $arg =~ m/-delay(\d+)/; + + $FIND_ONLY=1, next if $arg =~/^-f(ind)?$/;## do "find" only + + $FIND_ONLY=1, $DOREP=1, $all=1, + next if $arg =~/^-ff(ind)?$/;## fast -find + $LIST_ONLY=1,$opt{'-list'}=1, + next if $arg =~/^-l(ist)?$/;## only list files + + if ($arg =~ m/^-(v+)$/) { ## verbosity + $VERBOSE =length($1); + foreach $len (1..$VERBOSE) { $opt{'-'.('v' x $len)}=1 } + next; + } + if ($arg =~ m/^-(n+)ice$/) { ## "nice" output + $NICE =length($1); + foreach $len (1..$NICE) { $opt{'-'.('n' x $len).'ice'}=1 } + next; + } + + if ($arg =~ m/^-(i?)(d?)skip$/) { + local($i) = $1 eq 'i'; + local($d) = $2 eq 'd'; + $! = 2, die qq/$0: expecting glob arg to -$arg\n/ unless @ARGV; + foreach (split(/\s+/, shift @ARGV)) { + if ($d) { + $idskip{$_}=1 if $i; + $dskip{$_}=1; + } else { + $iskip{$_}=1 if $i; + $skip{$_}=1; + } + } + next; + } + + + if ($arg =~ m/^-(i?)(d?)(regex|path|name)$/) { + local($i) = $1 eq 'i'; + $! = 2, die qq/$0: expecting arg to -$arg\n/ unless @ARGV; + foreach (split(/\s+/, shift @ARGV)) { + $iname{join(',', $arg, $_)}=1 if $i; + $name{join(',', $arg, $_)}=1; + } + next; + } + + if ($arg =~ m/^-d?dir$/) { + $opt{'-dir'}=1; + $! = 2, die qq/$0: expecting filename arg to -$arg\n/ unless @ARGV; + $start = shift(@ARGV); + $start =~ s#^~(/+|$)#$ENV{'HOME'}$1# if defined $ENV{'HOME'}; + $! = 2, die qq/$0: can't find ${arg}'s "$start"\n/ unless -e $start; + $! = 2, die qq/$0: ${arg}'s "$start" not a directory.\n/ unless -d _; + undef(@todo), $opt{'-ddir'}=1 if $arg eq '-ddir'; + push(@todo, $start); + next; + } + + if ($arg =~ m/^-(new|old)er$/i) { + $! = 2, die "$0: expecting filename arg to -$arg\n" unless @ARGV; + local($file, $time) = shift(@ARGV); + $! = 2, die qq/$0: can't stat -${arg}'s "$file"./ + unless $time = (stat($file))[$STAT_MTIME]; + local($upper) = $arg =~ tr/A-Z//; + if ($arg =~ m/new/i) { + $time++ unless $upper; + $NEWER = $time if $NEWER < $time; + } else { + $time-- unless $upper; + $OLDER = $time if $OLDER == 0 || $OLDER > $time; + } + next; + } + + if ($arg =~ m/-mtime/) { + $! = 2, die "$0: expecting numerical arg to -$arg\n" unless @ARGV; + local($days) = shift(@ARGV); + $! = 2, die qq/$0: inappropriate arg ($days) to $arg\n/ if $days==0; + $days *= 3600 * 24; + if ($days < 0) { + local($time) = $^T + $days; + $NEWER = $time if $NEWER < $time; + } else { + local($time) = $^T - $days; + $OLDER = $time if $OLDER == 0 || $OLDER > $time; + } + next; + } + + ## special user options + if ($arg =~ m/^-x(.+)/) { + foreach (split(/[\s,]+/, $1)) { $user_opt{$_} = $opt{$_}= 1; } + next; + } + + $! = 2, die "$0: unknown arg [$arg]\n"; + } +} + +## +## Given a filename glob, return a regex. +## If the glob has no globbing chars (no * ? or [..]), then +## prepend an effective '*' to it. +## +sub glob_to_regex +{ + local($glob) = @_; + local(@parts) = $glob =~ m/\\.|[*?]|\[]?[^]]*]|[^[\\*?]+/g; + local($trueglob)=0; + foreach (@parts) { + if ($_ eq '*' || $_ eq '?') { + $_ = ".$_"; + $trueglob=1; ## * and ? are a real glob + } elsif (substr($_, 0, 1) eq '[') { + $trueglob=1; ## [..] is a real glob + } else { + s/^\\//; ## remove any leading backslash; + s/\W/\\$&/g; ## now quote anything dangerous; + } + } + unshift(@parts, '.*') unless $trueglob; + join('', '^', @parts, '$'); +} + +sub prepare_to_search +{ + local($rc_file) = @_; + + $HEADER_BYTES=0; ## Might be set nonzero in &read_rc; + $last_message_length = 0; ## For &message and &clear_message. + + &read_rc($rc_file, $showrc) unless $norc; + exit(0) if $showrc; + + $NEXT_DIR_ENTRY = $DO_SORT ? 'shift @files' : 'readdir(DIR)'; + $WHY = 1 if $VERBOSE > 3; ## Arg -vvvv or above implies -why. + @todo = ('.') if @todo == 0; ## Where we'll start looking + + ## see if any user options were specified that weren't accounted for + foreach $opt (keys %user_opt) { + next if defined $seen_opt{$opt}; + warn "warning: -x$opt never considered.\n"; + } + + die "$0: multiple time constraints exclude all possible files.\n" + if ($NEWER && $OLDER) && ($NEWER > $OLDER); + + ## + ## Process any -skip/-iskip args that had been given + ## + local(@skip_test); + foreach $glob (keys %skip) { + $i = defined($iskip{$glob}) ? 'i': ''; + push(@skip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i"); + } + if (@skip_test) { + $SKIP_TEST = join('||',@skip_test); + $DO_SKIP_TEST = 1; + } else { + $DO_SKIP_TEST = $SKIP_TEST = 0; + } + + ## + ## Process any -dskip/-idskip args that had been given + ## + local(@dskip_test); + foreach $glob (keys %dskip) { + $i = defined($idskip{$glob}) ? 'i': ''; + push(@dskip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i"); + } + if (@dskip_test) { + $DSKIP_TEST = join('||',@dskip_test); + $DO_DSKIP_TEST = 1; + } else { + $DO_DSKIP_TEST = $DSKIP_TEST = 0; + } + + + ## + ## Process any -name, -path, -regex, etc. args that had been given. + ## + undef @name_test; + undef @dname_test; + foreach $key (keys %name) { + local($type, $pat) = split(/,/, $key, 2); + local($i) = defined($iname{$key}) ? 'i' : ''; + if ($type =~ /regex/) { + $pat =~ s/!/\\!/g; + $test = "\$name =~ m!^$pat\$!$i"; + } else { + local($var) = $type eq 'name' ? '$name' : '$file'; + $test = "$var =~ m/". &glob_to_regex($pat). "/$i"; + } + if ($type =~ m/^-i?d/) { + push(@dname_test, $test); + } else { + push(@name_test, $test); + } + } + if (@name_test) { + $GLOB_TESTS = join('||', @name_test); + + $DO_GLOB_TESTS = 1; + } else { + $GLOB_TESTS = $DO_GLOB_TESTS = 0; + } + if (@dname_test) { + $DGLOB_TESTS = join('||', @dname_test); + $DO_DGLOB_TESTS = 1; + } else { + $DGLOB_TESTS = $DO_DGLOB_TESTS = 0; + } + + + ## + ## Process any 'magic' things from the startup file. + ## + if (@magic_tests && $HEADER_BYTES) { + ## the $magic' one is for when &dodir is not inlined + $tests = join('||',@magic_tests); + $MAGIC_TESTS = " { package magic; \$val = ($tests) }"; + $DO_MAGIC_TESTS = 1; + } else { + $MAGIC_TESTS = 1; + $DO_MAGIC_TESTS = 0; + } + + ## + ## Prepare regular expressions. + ## + { + local(@regex_tests); + + if ($LIST_ONLY) { + $mflag = ''; + ## need to have $* set, but perl5 just won''t shut up about it. + if ($] >= 5) { + $mflag = 'm'; + } else { + eval ' $* = 1 '; + } + } + + ## + ## Until I figure out a better way to deal with it, + ## We have to worry about a regex like [^xyz] when doing $LIST_ONLY. + ## Such a regex *will* match \n, and if I'm pulling in multiple + ## lines, it can allow lines to match that would otherwise not match. + ## + ## Therefore, if there is a '[^' in a regex, we can NOT take a chance + ## an use the fast listonly. + ## + $CAN_USE_FAST_LISTONLY = $LIST_ONLY; + + local(@extra); + local($underline_glue) = ($] >= 5) ? '(:?_\cH)?' : '(_\cH)?'; + while (@ARGV) { + $regex = shift(@ARGV); + ## + ## If watching for underlined things too, add another regex. + ## + if ($underlineOK) { + if ($regex =~ m/[?*+{}()\\.|^\$[]/) { + warn "$0: warning, can't underline-safe ``$regex''.\n"; + } else { + $regex = join($underline_glue, split(//, $regex)); + } + } + + ## If nothing special in the regex, just use index... + ## is quite a bit faster. + if (($iflag eq '') && ($words == 0) && + $regex !~ m/[?*+{}()\\.|^\$[]/) + { + push(@regex_tests, "(index(\$_, q+$regex+)>=0)"); + + } else { + $regex =~ s#[\$\@\/]\w#\\$&#; + if ($words) { + if ($regex =~ m/\|/) { + ## could be dangerous -- see if we can wrap in parens. + if ($regex =~ m/\\\d/) { + warn "warning: -w and a | in a regex is dangerous.\n" + } else { + $regex = join($regex, '(', ')'); + } + } + $regex = join($regex, '\b', '\b'); + } + $CAN_USE_FAST_LISTONLY = 0 if substr($regex, "[^") >= 0; + push(@regex_tests, "m/$regex/$iflag$mflag"); + } + + ## If we're done, but still have @extra to do, get set for that. + if (@ARGV == 0 && @extra) { + @ARGV = @extra; ## now deal with the extra stuff. + $underlineOK = 0; ## but no more of this. + undef @extra; ## or this. + } + } + if (@regex_tests) { + $REGEX_TEST = join('||', @regex_tests); + ## print STDERR $REGEX_TEST, "\n"; exit; + } else { + ## must be doing -find -- just give something syntactically correct. + $REGEX_TEST = 1; + } + } + + ## + ## Make sure we can read the first item(s). + ## + foreach $start (@todo) { + $! = 2, die qq/$0: can't stat "$start"\n/ + unless ($dev,$inode) = (stat($start))[$STAT_DEV,$STAT_INODE]; + + if (defined $dir_done{"$dev,$inode"}) { + ## ignore the repeat. + warn(qq/ignoring "$start" (same as "$dir_done{"$dev,$inode"}").\n/) + if $VERBOSE; + next; + } + + ## if -xdev was given, remember the device. + $xdev{$dev} = 1 if $XDEV; + + ## Note that we won't want to do it again + $dir_done{"$dev,$inode"} = $start; + } +} + + +## +## See the comment above the __END__ above the 'sub dodir' below. +## +sub import_program +{ + sub bad { + print STDERR "$0: internal error (@_)\n"; + exit 2; + } + + ## Read from data, up to next __END__. This will be &dodir. + local($/) = "\n__END__"; + $prog = <DATA>; + close(DATA); + + $prog =~ s/\beval\b//g; ## remove any 'eval' + + ## Inline uppercase $-variables by their current values. + if ($] >= 5) { + $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/ + &bad($1) if !defined ${$main::{$1}}; ${$main::{$1}};/eg; + } else { + $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/local(*VAR) = $_main{$1}; + &bad($1) if !defined $VAR; $VAR;/eg; + } + + eval $prog; ## now do it. This will define &dodir; + $!=2, die "$0 internal error: $@\n" if $@; +} + +########################################################################### + +## +## Read the .search file: +## Blank lines and lines that are only #-comments ignored. +## Newlines may be escaped to create long lines +## Other lines are directives. +## +## A directive may begin with an optional tag in the form <...> +## Things inside the <...> are evaluated as with: +## <(this || that) && must> +## will be true if +## -xmust -xthis or -xmust -xthat +## were specified on the command line (order doesn't matter, though) +## A directive is not done if there is a tag and it's false. +## Any characters but whitespace and &|()>,! may appear after an -x +## (although "-xdev" is special). -xmust,this is the same as -xmust -xthis. +## Something like -x~ would make <~> true, and <!~> false. +## +## Directives are in the form: +## option: STRING +## magic : NUMBYTES : EXPR +## +## With option: +## The STRING is parsed like a Bourne shell command line, and the +## options are used as if given on the command line. +## No comments are allowed on 'option' lines. +## Examples: +## # skip objects and libraries +## option: -skip '.o .a' +## # skip emacs *~ and *# files, unless -x~ given: +## <!~> option: -skip '~ #' +## +## With magic: +## EXPR can be pretty much any perl (comments allowed!). +## If it evaluates to true for any particular file, it is skipped. +## The only info you'll have about a file is the variable $H, which +## will have at least the first NUMBYTES of the file (less if the file +## is shorter than that, of course, and maybe more). You'll also have +## any variables you set in previous 'magic' lines. +## Examples: +## magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a' +## magic: 6 : $x6 eq 'GIF89a' +## +## magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a' ## old gif \ +## || $x6 eq 'GIF89a' ## new gif +## (the above two sets are the same) +## ## Check the first 32 bytes for "binarish" looking bytes. +## ## Don't blindly dump on any high-bit set, as non-ASCII text +## ## often has them set. \x80 and \xff seem to be special, though. +## ## Require two in a row to not get things like perl's $^T. +## ## This is known to get *.Z, *.gz, pkzip, *.elc and about any +## ## executable you'll find. +## magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/ +## +sub read_rc +{ + local($file, $show) = @_; + local($line_num, $ln, $tag) = 0; + local($use_default, @default) = 0; + + { package magic; $ = 0; } ## turn off warnings for when we run EXPR's + + unless (open(RC, "$file")) { + $use_default=1; + $file = "<internal default startup file>"; + ## no RC file -- use this default. + @default = split(/\n/,<<'--------INLINE_LITERAL_TEXT'); + magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/ + option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi' + option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu' + <!~> option: -skip '~ #' +--------INLINE_LITERAL_TEXT + } + + ## + ## Make an eval error pretty. + ## + sub clean_eval_error { + local($_) = @_; + s/ in file \(eval\) at line \d+,//g; ## perl4-style error + s/ at \(eval \d+\) line \d+,//g; ## perl5-style error + $_ = $` if m/\n/; ## remove all but first line + "$_\n"; + } + + print "reading RC file: $file\n" if $show; + + while (defined($_ = ($use_default ? shift(@default) : <RC>))) { + $ln = ++$line_num; ## note starting line num. + $_ .= <RC>, $line_num++ while s/\\\n?$/\n/; ## allow continuations + next if /^\s*(#.*)?$/; ## skip blank or comment-only lines. + $do = ''; + + ## look for an initial <...> tag. + if (s/^\s*<([^>]*)>//) { + ## This simple s// will make the tag ready to eval. + ($tag = $msg = $1) =~ + s/[^\s&|(!)]+/ + $seen_opt{$&}=1; ## note seen option + "defined(\$opt{q>$&>})" ## (q>> is safe quoting here) + /eg; + + ## see if the tag is true or not, abort this line if not. + $dothis = (eval $tag); + $!=2, die "$file $ln <$msg>: $_".&clean_eval_error($@) if $@; + + if ($show) { + $msg =~ s/[^\s&|(!)]+/-x$&/; + $msg =~ s/\s*!\s*/ no /g; + $msg =~ s/\s*&&\s*/ and /g; + $msg =~ s/\s*\|\|\s*/ or /g; + $msg =~ s/^\s+//; $msg =~ s/\s+$//; + $do = $dothis ? "(doing because $msg)" : + "(do if $msg)"; + } elsif (!$dothis) { + next; + } + } + + if (m/^\s*option\s*:\s*/) { + next if $all && !$show; ## -all turns off these checks; + local($_) = $'; + s/\n$//; + local($orig) = $_; + print " $do option: $_\n" if $show; + local($0) = "$0 ($file)"; ## for any error message. + local(@ARGV); + local($this); + ## + ## Parse $_ as a Bourne shell line -- fill @ARGV + ## + while (length) { + if (s/^\s+//) { + push(@ARGV, $this) if defined $this; + undef $this; + next; + } + $this = '' if !defined $this; + $this .= $1 while s/^'([^']*)'// || + s/^"([^"]*)"// || + s/^([^'"\s\\]+)//|| + s/^(\\[\D\d])//; + die "$file $ln: error parsing $orig at $_\n" if m/^\S/; + } + push(@ARGV, $this) if defined $this; + &check_args; + die qq/$file $ln: unused arg "@ARGV".\n/ if @ARGV; + next; + } + + if (m/^\s*magic\s*:\s*(\d+)\s*:\s*/) { + next if $all && !$show; ## -all turns off these checks; + local($bytes, $check) = ($1, $'); + + if ($show) { + $check =~ s/\n?$/\n/; + print " $do contents: $check"; + } + ## Check to make sure the thing at least compiles. + eval "package magic; (\$H = '1'x \$main'bytes) && (\n$check\n)\n"; + $! = 2, die "$file $ln: ".&clean_eval_error($@) if $@; + + $HEADER_BYTES = $bytes if $bytes > $HEADER_BYTES; + push(@magic_tests, "(\n$check\n)"); + next; + } + $! = 2, die "$file $ln: unknown command\n"; + } + close(RC); +} + +sub message +{ + if (!$STDERR_IS_TTY) { + print STDERR $_[0], "\n"; + } else { + local($text) = @_; + $thislength = length($text); + if ($thislength >= $last_message_length) { + print STDERR $text, "\r"; + } else { + print STDERR $text, ' 'x ($last_message_length-$thislength),"\r"; + } + $last_message_length = $thislength; + } +} + +sub clear_message +{ + print STDERR ' ' x $last_message_length, "\r" if $last_message_length; + $vv_print = $vv_size = $last_message_length = 0; +} + +## +## Output a copy of this program with comments, extra whitespace, and +## the trailing man page removed. On an ultra slow machine, such a copy +## might load faster (but I can't tell any difference on my machine). +## +sub strip { + seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n"; + while(<DATA>) { + print, next if /INLINE_LITERAL_TEXT/.../INLINE_LITERAL_TEXT/; + ## must mention INLINE_LITERAL_TEXT on this line! + s/\#\#.*|^\s+|\s+$//; ## remove cruft + last if $_ eq '.00;'; + next if ($_ eq '') || ($_ eq "'di'") || ($_ eq "'ig00'"); + s/\$stripped=0;/\$stripped=1;/; + s/\s\s+/ /; ## squish multiple whitespaces down to one. + print $_, "\n"; + } + exit(0); +} + +## +## Just to shut up -w. Never executed. +## +sub dummy { + + 1 || &dummy || &dir_done || &bad || &message || $NEXT_DIR_ENTRY || + $DELAY || $VV_SIZE || $VV_PRINT_COUNT || $STDERR_SCREWS_STDOUT || + @files || @files || $magic'H || $magic'H || $xdev{''} || &clear_message; + +} + +## +## If the following __END__ is in place, what follows will be +## inlined when the program first starts up. Any $ variable name +## all in upper case, specifically, any string matching +## \$([A-Z][A-Z0-9_]{2,}\b +## will have the true value for that variable inlined. Also, any 'eval' is +## removed +## +## The idea is that when the whole thing is then eval'ed to define &dodir, +## the perl optimizer will make all the decisions that are based upon +## command-line options (such as $VERBOSE), since they'll be inlined as +## constants +## +## Also, and here's the big win, the tests for matching the regex, and a +## few others, are all inlined. Should be blinding speed here. +## +## See the read from <DATA> above for where all this takes place. +## But all-in-all, you *want* the __END__ here. Comment it out only for +## debugging.... +## + +__END__ + +## +## Given a directory, check all "appropriate" files in it. +## Shove any subdirectories into the global @todo, so they'll be done +## later. +## +## Be careful about adding any upper-case variables, as they are subject +## to being inlined. See comments above the __END__ above. +## +sub dodir +{ + local($dir) = @_; + $dir =~ s,/+$,,; ## remove any trailing slash. + unless (opendir(DIR, "$dir/.")) { + &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; + warn qq($0: can't opendir "$dir/".\n); + return; + } + + if ($VERBOSE) { + &message($dir); + $vv_print = $vv_size = 0; + } + + @files = sort readdir(DIR) if $DO_SORT; + + while (defined($name = eval $NEXT_DIR_ENTRY)) + { + next if $name eq '.' || $name eq '..'; ## never follow these. + + ## create full relative pathname. + $file = $dir eq '.' ? $name : "$dir/$name"; + + ## if link and skipping them, do so. + if ($NOLINKS && -l $file) { + warn qq/skip (symlink): $file\n/ if $WHY; + next; + } + + ## skip things unless files or directories + unless (-f $file || -d _) { + if ($WHY) { + $why = (-S _ && "socket") || + (-p _ && "pipe") || + (-b _ && "block special")|| + (-c _ && "char special") || "somekinda special"; + warn qq/skip ($why): $file\n/; + } + next; + } + + ## skip things we can't read + unless (-r _) { + if ($WHY) { + $why = (-l $file) ? "follow" : "read"; + warn qq/skip (can't $why): $file\n/; + } + next; + } + + ## skip things that are empty + unless (-s _) { + warn qq/skip (empty): $file\n/ if $WHY; + next; + } + + ## Note file device & inode. If -xdev, skip if appropriate. + ($dev, $inode) = (stat(_))[$STAT_DEV, $STAT_INODE]; + if ($XDEV && defined $xdev{$dev}) { + warn qq/skip (other device): $file\n/ if $WHY; + next; + } + $id = "$dev,$inode"; + + ## special work for a directory + if (-d _) { + ## Do checks for directory file endings. + if ($DO_DSKIP_TEST && (eval $DSKIP_TEST)) { + warn qq/skip (-dskip): $file\n/ if $WHY; + next; + } + ## do checks for -name/-regex/-path tests + if ($DO_DGLOB_TESTS && !(eval $DGLOB_TESTS)) { + warn qq/skip (dirname): $file\n/ if $WHY; + next; + } + + ## _never_ redo a directory + if (defined $dir_done{$id}) { + warn qq/skip (did as "$dir_done{$id}"): $file\n/ if $WHY; + next; + } + $dir_done{$id} = $file; ## mark it done. + unshift(@todo, $file); ## add to the list to do. + next; + } + if ($WHY == 0 && $VERBOSE > 1) { + if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){ + &message($file); + $vv_print = $vv_size = 0; + } + } + + ## do time-related tests + if ($NEWER || $OLDER) { + $_ = (stat(_))[$STAT_MTIME]; + if ($NEWER && $_ < $NEWER) { + warn qq/skip (too old): $file\n/ if $WHY; + next; + } + if ($OLDER && $_ > $OLDER) { + warn qq/skip (too new): $file\n/ if $WHY; + next; + } + } + + ## do checks for file endings + if ($DO_SKIP_TEST && (eval $SKIP_TEST)) { + warn qq/skip (-skip): $file\n/ if $WHY; + next; + } + + ## do checks for -name/-regex/-path tests + if ($DO_GLOB_TESTS && !(eval $GLOB_TESTS)) { + warn qq/skip (filename): $file\n/ if $WHY; + next; + } + + + ## If we're not repeating files, + ## skip this one if we've done it, or note we're doing it. + unless ($DOREP) { + if (defined $file_done{$id}) { + warn qq/skip (did as "$file_done{$id}"): $file\n/ if $WHY; + next; + } + $file_done{$id} = $file; + } + + if ($DO_MAGIC_TESTS) { + if (!open(FILE_IN, $file)) { + &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; + warn qq/$0: can't open: $file\n/; + next; + } + unless (read(FILE_IN, $magic'H, $HEADER_BYTES)) { + &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; + warn qq/$0: can't read from "$file"\n"/; + close(FILE_IN); + next; + } + + eval $MAGIC_TESTS; + if ($magic'val) { + close(FILE_IN); + warn qq/skip (magic): $file\n/ if $WHY; + next; + } + seek(FILE_IN, 0, 0); ## reset for later <FILE_IN> + } + + if ($WHY != 0 && $VERBOSE > 1) { + if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){ + &message($file); + $vv_print = $vv_size = 0; + } + } + + if ($DELAY) { + sleep($DELAY); + } + + if ($FIND_ONLY) { + &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; + print $file, "\n"; + $retval=0; ## we've found something + close(FILE_IN) if $DO_MAGIC_TESTS; + next; + } else { + ## if we weren't doing magic tests, file won't be open yet... + if (!$DO_MAGIC_TESTS && !open(FILE_IN, $file)) { + &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; + warn qq/$0: can't open: $file\n/; + next; + } + if ($LIST_ONLY && $CAN_USE_FAST_LISTONLY) { + ## + ## This is rather complex, but buys us a LOT when we're just + ## listing files and not the individual internal lines. + ## + local($size) = 4096; ## block-size in which to do reads + local($nl); ## will point to $_'s ending newline. + local($read); ## will be how many bytes read. + local($_) = ''; ## Starts out empty + local($hold); ## (see below) + + while (($read = read(FILE_IN,$_,$size,length($_)))||length($_)) + { + undef @parts; + ## if read a full block, but no newline, need to read more. + while ($read == $size && ($nl = rindex($_, "\n")) < 0) { + push(@parts, $_); ## save that part + $read = read(FILE_IN, $_, $size); ## keep trying + } + + ## + ## If we had to save parts, must now combine them together. + ## adjusting $nl to reflect the now-larger $_. This should + ## be a lot more efficient than using any kind of .= in the + ## loop above. + ## + if (@parts) { + local($lastlen) = length($_); #only need if $nl >= 0 + $_ = join('', @parts, $_); + $nl = length($_) - ($lastlen - $nl) if $nl >= 0; + } + + ## + ## If we're at the end of the file, then we can use $_ as + ## is. Otherwise, we need to remove the final partial-line + ## and save it so that it'll be at the beginning of the + ## next read (where the rest of the line will be layed in + ## right after it). $hold will be what we should save + ## until next time. + ## + if ($read != $size || $nl < 0) { + $hold = ''; + } else { + $hold = substr($_, $nl + 1); + substr($_, $nl + 1) = ''; + } + + ## + ## Now have a bunch of full lines in $_. Use it. + ## + if (eval $REGEX_TEST) { + &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; + print $file, "\n"; + $retval=0; ## we've found something + + last; + } + + ## Prepare for next read.... + $_ = $hold; + } + + } else { ## else not using faster block scanning..... + + $lines_printed = 0 if $NICE; + while (<FILE_IN>) { + study; + next unless (eval $REGEX_TEST); + + ## + ## We found a matching line. + ## + $retval=0; + &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT; + if ($LIST_ONLY) { + print $file, "\n"; + last; + } else { + ## prepare to print line. + if ($NICE && $lines_printed++ == 0) { + print '-' x 70, "\n" if $NICE > 1; + print $file, ":\n"; + } + + ## + ## Print all the prelim stuff. This looks less efficient + ## than it needs to be, but that's so that when the eval + ## is compiled (and the tests are optimized away), the + ## result will be less actual PRINTs than the more natural + ## way of doing these tests.... + ## + if ($NICE) { + if ($REPORT_LINENUM) { + print " line $.: "; + } else { + print " "; + } + } elsif ($REPORT_LINENUM && $PREPEND_FILENAME) { + print "$file,:$.: "; + } elsif ($PREPEND_FILENAME) { + print "$file: "; + } elsif ($REPORT_LINENUM) { + print "$.: "; + } + print $_; + print "\n" unless m/\n$/; + } + } + print "\n" if ($NICE > 1) && $lines_printed; + } + close(FILE_IN); + } + } + closedir(DIR); +} + +__END__ +.00; ## finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +.\"__________________NORMAL_MAN_PAGE_BELOW_________________ +.ll+10n +.TH search 1 "Dec 17, 1994" +.SH SEARCH +search \- search files (a'la grep) in a whole directory tree. +.SH SYNOPSIS +search [ grep-like and find-like options] [regex ....] +.SH DESCRIPTION +.I Search +is more or less a combo of 'find' and 'grep' (although the regular +expression flavor is that of the perl being used, which is closer to +egrep's than grep's). + +.I Search +does generally the same kind of thing that +.nf + find <blah blah> | xargs egrep <blah blah> +.fi +does, but is +.I much +more powerful and efficient (and intuitive, I think). + +This manual describes +.I search +as of version "941227.4". You can always find the latest version at +.nf + http://www.wg.omron.co.jp/~jfriedl/perl/index.html +.fi + +.SH "QUICK EXAMPLE" +Basic use is simple: +.nf + % search jeff +.fi +will search files in the current directory, and all sub directories, for +files that have "jeff" in them. The lines will be listed with the +containing file's name prepended. +.PP +If you list more than one regex, such as with +.nf + % search jeff Larry Randal+ 'Stoc?k' 'C.*son' +.fi +then a line containing any of the regexes will be listed. +This makes it effectively the same as +.nf + % search 'jeff|Larry|Randal+|Stoc?k|C.*son' +.fi +However, listing them separately is much more efficient (and is easier +to type). +.PP +Note that in the case of these examples, the +.B \-w +(list whole-words only) option would be useful. +.PP +Normally, various kinds of files are automatically removed from consideration. +If it has has a certain ending (such as ".tar", ".Z", ".o", .etc), or if +the beginning of the file looks like a binary, it'll be excluded. +You can control exactly how this works -- see below. One quick way to +override this is to use the +.B \-all +option, which means to consider all the files that would normally be +automatically excluded. +Or, if you're curious, you can use +.B \-why +to have notes about what files are skipped (and why) printed to stderr. + +.SH "BASIC OVERVIEW" +Normally, the search starts in the current directory, considering files in +all subdirectories. + +You can use the +.I ~/.search +file to control ways to automatically exclude files. +If you don't have this file, a default one will kick in, which automatically +add +.nf + -skip .o .Z .gif +.fi +(among others) to exclude those kinds of files (which you probably want to +skip when searching for text, as is normal). +Files that look to be be binary will also be excluded. + +Files ending with "#" and "~" will also be excluded unless the +.B -x~ +option is given. + +You can use +.B -showrc +to show what kinds of files will normally be skipped. +See the section on the startup file +for more info. + +You can use the +.B -all +option to indicate you want to consider all files that would otherwise be +skipped by the startup file. + +Based upon various other flags (see "WHICH FILES TO CONSIDER" below), +more files might be removed from consideration. For example +.nf + -mtime 3 +.fi +will exclude files that aren't at least three days old (change the 3 to -3 +to exclude files that are more than three days old), while +.nf + -skip .* +.fi +would exclude any file beginning with a dot (of course, '.' and '..' are +special and always excluded). + +If you'd like to see what files are being excluded, and why, you can get the +list via the +.B \-why +option. + +If a file makes it past all the checks, it is then "considered". +This usually means it is greped for the regular expressions you gave +on the command line. + +If any of the regexes match a line, the line is printed. +However, if +.B -list +is given, just the filename is printed. Or, if +.B -nice +is given, a somewhat more (human-)readable output is generated. + +If you're searching a huge tree and want to keep informed about how +the search is progressing, +.B -v +will print (to stderr) the current directory being searched. +Using +.B -vv +will also print the current file "every so often", which could be useful +if a directory is huge. Using +.B -vvv +will print the update with every file. + +Below is the full listing of options. + +.SH "OPTIONS TELLING *WHERE* TO SEARCH" +.TP +.BI -dir " DIR" +Start searching at the named directory instead of the current directory. +If multiple +.B -dir +arguments are given, multiple trees will be searched. +.TP +.BI -ddir " DIR" +Like +.B -dir +except it flushes any previous +.B -dir +directories (i.e. "-dir A -dir B -dir C" will search A, B, and C, while +"-dir A -ddir B -dir C" will search only B and C. This might be of use +in the startup file (see that section below). +.TP +.B -xdev +Stay on the same filesystem as the starting directory/directories. +.TP +.B -sort +Sort the items in a directory before processing them. +Normally they are processed in whatever order they happen to be read from +the directory. +.TP +.B -nolinks +Don't follow symbolic links. Normally they're followed. + +.SH "OPTIONS CONTROLLING WHICH FILES TO CONSIDER AND EXCLUDE" +.TP +.BI -mtime " NUM" +Only consider files that were last changed more than +.I NUM +days ago +(less than +.I NUM +days if +.I NUM +has '-' prepended, i.e. "-mtime -2.5" means to consider files that +have been changed in the last two and a half days). +.TP +.B -older FILE +Only consider files that have not changed since +.I FILE +was last changed. +If there is any upper case in the "-older", "or equal" is added to the sense +of the test. Therefore, "search -older ./file regex" will never consider +"./file", while "search -Older ./file regex" will. + +If a file is a symbolic link, the time used is that of the file and not the +link. +.TP +.BI -newer " FILE" +Opposite of +.BR -older . +.TP +.BI -name " GLOB" +Only consider files that match the shell filename pattern +.IR GLOB . +The check is only done on a file's name (use +.B -path +to check the whole path, and use +.B -dname +to check directory names). + +Multiple specifications can be given by separating them with spaces, a'la +.nf + -name '*.c *.h' +.fi +to consider C source and header files. +If +.I GLOB +doesn't contain any special pattern characters, a '*' is prepended. +This last example could have been given as +.nf + -name '.c .h' +.fi +It could also be given as +.nf + -name .c -name .h +.fi +or +.nf + -name '*.c' -name '*.h' +.fi +or +.nf + -name '*.[ch]' +.fi +(among others) +but in this last case, you have to be sure to supply the leading '*'. +.TP +.BI -path " GLOB" +Like +.B -name +except the entire path is checked against the pattern. +.TP +.B -regex " REGEX" +Considers files whose names (not paths) match the given perl regex +exactly. +.TP +.BI -iname " GLOB" +Case-insensitive version of +.BR -name . +.TP +.BI -ipath " GLOB" +Case-insensitive version of +.BR -path . +.TP +.BI -iregex " REGEX" +Case-insensitive version of +.BR -regex . + +.TP +.BI -dpath " GLOB" +Only search down directories whose path matches the given pattern (this +doesn't apply to the initial directory given by +.BI -dir , +of course). +Something like +.nf + -dir /usr/man -dpath /usr/man/man* +.fi +would completely skip +"/usr/man/cat1", "/usr/man/cat2", etc. +.TP +.BI -dskip " GLOB" +Skips directories whose name (not path) matches the given pattern. +Something like +.nf + -dir /usr/man -dskip cat* +.fi +would completely skip any directory in the tree whose name begins with "cat" +(including "/usr/man/cat1", "/usr/man/cat2", etc.). +.TP +.BI -dregex " REGEX" +Like +.BI -dpath , +but the pattern is a full perl regex. Note that this quite different +from +.B -regex +which considers only file names (not paths). This option considers +full directory paths (not just names). It's much more useful this way. +Sorry if it's confusing. +.TP +.BI -dpath " GLOB" +This option exists, but is probably not very useful. It probably wants to +be like the '-below' or something I mention in the "TODO" section. +.TP +.BI -idpath " GLOB" +Case-insensitive version of +.BR -dpath . +.TP +.BI -idskip " GLOB" +Case-insensitive version of +.BR -dskip . +.TP +.BI -idregex " REGEX" +Case-insensitive version of +.BR -dregex . +.TP +.B -all +Ignore any 'magic' or 'option' lines in the startup file. +The effect is that all files that would otherwise be automatically +excluded are considered. +.TP +.BI -x SPECIAL +Arguments starting with +.B -x +(except +.BR -xdev , +explained elsewhere) do special interaction with the +.I ~/.search +startup file. Something like +.nf + -xflag1 -xflag2 +.fi +will turn on "flag1" and "flag2" in the startup file (and is +the same as "-xflag1,flag2"). You can use this to write your own +rules for what kinds of files are to be considered. + +For example, the internal-default startup file contains the line +.nf + <!~> option: -skip '~ #' +.fi +This means that if the +.B -x~ +flag is +.I not +seen, the option +.nf + -skip '~ #' +.fi +should be done. +The effect is that emacs temp and backup files are not normally +considered, but you can included them with the -x~ flag. + +You can write your own rules to customize +.I search +in powerful ways. See the STARTUP FILE section below. +.TP +.B -why +Print a message (to stderr) when and why a file is not considered. + +.SH "OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED" +.TP +.B -find +(you can use +.B -f +as well). +This option changes the basic action of +.IR search . + +Normally, if a file is considered, it is searched +for the regular expressions as described earlier. However, if this option +is given, the filename is printed and no searching takes place. This turns +.I search +into a 'find' of some sorts. + +In this case, no regular expressions are needed on the command line +(any that are there are silently ignored). + +This is not intended to be a replacement for the 'find' program, +but to aid +you in understanding just what files are getting past the exclusion checks. +If you really want to use it as a sort of replacement for the 'find' program, +you might want to use +.B -all +so that it doesn't waste time checking to see if the file is binary, etc +(unless you really want that, of course). + +If you use +.BR -find , +none of the "GREP-LIKE OPTIONS" (below) matter. + +As a replacement for 'find', +.I search +is probably a bit slower (or in the case of GNU find, a lot slower -- +GNU find is +.I unbelievably +fast). +However, "search -ffind" +might be more useful than 'find' when options such as +.B -skip +are used (at least until 'find' gets such functionality). +.TP +.B -ffind +(or +.BR -ff ) +A faster more 'find'-like find. Does +.nf + -find -all -dorep +.fi +.SH "GREP-LIKE OPTIONS" +These options control how a searched file is accessed, +and how things are printed. +.TP +.B -i +Ignore letter case when matching. +.TP +.B -w +Consider only whole-word matches ("whole word" as defined by perl's "\\b" +regex). +.TP +.B -u +If the regex(es) is/are simple, try to modify them so that they'll work +in manpage-like underlined text (i.e. like _^Ht_^Hh_^Hi_^Hs). +This is very rudimentary at the moment. +.TP +.B -list +(you can use +.B -l +too). +Don't print matching lines, but the names of files that contain matching +lines. This will likely be *much* faster, as special optimizations are +made -- particularly with large files. +.TP +.B -n +Pepfix each line by its line number. +.TP +.B -nice +Not a grep-like option, but similar to +.BR -list , +so included here. +.B -nice +will have the output be a bit more human-readable, with matching lines printed +slightly indented after the filename, a'la +.nf + + % search foo + somedir/somefile: line with foo in it + somedir/somefile: some food for thought + anotherdir/x: don't be a buffoon! + % + +.fi +will become +.nf + + % search -nice foo + somedir/somefile: + line with foo in it + some food for thought + anotherdir/x: + don't be a buffoon! + % + +.fi +This option due to Lionel Cons. +.TP +.B -nnice +Be a bit nicer than +.BR -nice . +Prefix each file's output by a rule line, and follow with an extra blank line. +.TP +.B -h +Don't prepend each output line with the name of the file +(meaningless when +.B -find +or +.B -l +are given). + +.SH "OTHER OPTIONS" +.TP +.B -help +Print the usage information. +.TP +.B -version +Print the version information and quit. +.TP +.B -v +Set the level of message verbosity. +.B -v +will print a note whenever a new directory is entered. +.B -vv +will also print a note "every so often". This can be useful to see +what's happening when searching huge directories. +.B -vvv +will print a new with every file. +.B -vvvv +is +-vvv +plus +.BR -why . +.TP +.B -e +This ends the options, and can be useful if the regex begins with '-'. +.TP +.B -showrc +Shows what is being considered in the startup file, then exits. +.TP +.B -dorep +Normally, an identical file won't be checked twice (even with multiple +hard or symbolic links). If you're just trying to do a fast +.BR -find , +the bookkeeping to remember which files have been seen is not desirable, +so you can eliminate the bookkeeping with this flag. + +.SH "STARTUP FILE" +When +.I search +starts up, it processes the directives in +.IR ~/.search . +If no such file exists, a default +internal version is used. + +The internal version looks like: +.nf + + magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/ + option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi' + option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu' + <!~> option: -skip '~ #' + +.fi +If you wish to create your own "~/.search", +you might consider copying the above, and then working from there. + +There are two kinds of directives in a startup file: "magic" and "option". +.RS 0n +.TP +OPTION +Option lines will automatically do the command-line options given. +For example, the line +.nf + option: -v +.fi +in you startup file will turn on -v every time, without needing to type it +on the command line. + +The text on the line after the "option:" directive is processed +like the Bourne shell, so make sure to pay attention to quoting. +.nf + option: -skip .exe .com +.fi +will give an error (".com" by itself isn't a valid option), while +.nf + option: -skip ".exe .com" +.fi +will properly include it as part of -skip's argument. + +.TP +MAGIC +Magic lines are used to determine if a file should be considered a binary +or not (the term "magic" refers to checking a file's magic number). These +are described in more detail below. +.RE + +Blank lines and comments (lines beginning with '#') are allowed. + +If a line begins with <...>, then it's a check to see if the +directive on the line should be done or not. The stuff inside the <...> +can contain perl's && (and), || (or), ! (not), and parens for grouping, +along with "flags" that might be indicated by the user with +.BI -x flag +options. + +For example, using "-xfoo" will cause "foo" to be true inside the <...> +blocks. Therefore, a line beginning with "<foo>" would be done only when +"-xfoo" had been specified, while a line beginning with "<!foo>" would be +done only when "-xfoo" is not specified (of course, a line without any <...> +is done in either case). + +A realistic example might be +.nf + <!v> -vv +.fi +This will cause -vv messages to be the default, but allow "-xv" to override. + +There are a few flags that are set automatically: +.RS +.TP +.B TTY +true if the output is to the screen (as opposed to being redirected to a file). +You can force this (as with all the other automatic flags) with -xTTY. +.TP +.B -v +True if -v was specified. If -vv was specified, both +.B -v +and +.B -vv +flags are true (and so on). +.TP +.B -nice +True if -nice was specified. Same thing about -nnice as for -vv. +.PP +.TP +.B -list +true if -list (or -l) was given. +.TP +.B -dir +true if -dir was given. +.RE + +Using this info, you might change the last example to +.nf + + <!v && !-v> option: -vv + +.fi +The added "&& !-v" means "and if the '-v' option not given". +This will allow you to use "-v" alone on the command line, and not +have this directive add the more verbose "-vv" automatically. + +.RS 0 +Some other examples: +.TP +<!-dir && !here> option: -dir ~/ +Effectively make the default directory your home directory (instead of the +current directory). Using -dir or -xhere will undo this. +.TP +<tex> option: -name .tex -dir ~/pub +Create '-xtex' to search only "*.tex" files in your ~/pub directory tree. +Actually, this could be made a bit better. If you combine '-xtex' and '-dir' +on the command line, this directive will add ~/pub to the list, when you +probably want to use the -dir directory only. You could do +.nf + + <tex> option: -name .tex + <tex && !-dir> option: -dir ~/pub +.fi + +to will allow '-xtex' to work as before, but allow a command-line "-dir" +to take precedence with respect to ~/pub. +.TP +<fluff> option: -nnice -sort -i -vvv +Combine a few user-friendly options into one '-xfluff' option. +.TP +<man> option: -ddir /usr/man -v -w +When the '-xman' option is given, search "/usr/man" for whole-words +(of whatever regex or regexes are given on the command line), with -v. +.RE + +The lines in the startup file are executed from top to bottom, so something +like +.nf + + <both> option: -xflag1 -xflag2 + <flag1> option: ...whatever... + <flag2> option: ...whatever... + +.fi +will allow '-xboth' to be the same as '-xflag1 -xflag2' (or '-xflag1,flag2' +for that matter). However, if you put the "<both>" line below the others, +they will not be true when encountered, so the result would be different +(and probably undesired). + +The "magic" directives are used to determine if a file looks to be binary +or not. The form of a magic line is +.nf + magic: \fISIZE\fP : \fIPERLCODE\fP +.fi +where +.I SIZE +is the number of bytes of the file you need to check, and +.I PERLCODE +is the code to do the check. Within +.IR PERLCODE , +the variable $H will hold at least the first +.I SIZE +bytes of the file (unless the file is shorter than that, of course). +It might hold more bytes. The perl should evaluate to true if the file +should be considered a binary. + +An example might be +.nf + magic: 6 : substr($H, 0, 6) eq 'GIF87a' +.fi +to test for a GIF ("-iskip .gif" is better, but this might be useful +if you have images in files without the ".gif" extension). + +Since the startup file is checked from top to bottom, you can be a bit +efficient: +.nf + magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a' + magic: 6 : $x6 eq 'GIF89a' +.fi +You could also write the same thing as +.nf + magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a') || ## an old gif, or.. \e + $x6 eq 'GIF89a' ## .. a new one. +.fi +since newlines may be escaped. + +The default internal startup file includes +.nf + magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/ +.fi +which checks for certain non-printable characters, and catches a large +number of binary files, including most system's executables, linkable +objects, compressed, tarred, and otherwise folded, spindled, and mutilated +files. + +Another example might be +.nf + ## an archive library + magic: 17 : substr($H, 0, 17) eq "!<arch>\en__.SYMDEF" +.fi + +.SH "RETURN VALUE" +.I Search +returns zero if lines (or files, if appropriate) were found, +or if no work was requested (such as with +.BR -help ). +Returns 1 if no lines (or files) were found. +Returns 2 on error. + +.SH TODO +Things I'd like to add some day: +.nf + + show surrounding lines (context). + + highlight matched portions of lines. + + add '-and', which can go between regexes to override + the default logical or of the regexes. + + add something like + -below GLOB + which will examine a tree and only consider files that + lie in a directory deeper than one named by the pattern. + + add 'warning' and 'error' directives. + + add 'help' directive. +.fi +.SH BUGS +If -xdev and multiple -dir arguments are given, any file in any of the +target filesystems are allowed. It would be better to allow each filesystem +for each separate tree. + +Multiple -dir args might also cause some confusing effects. Doing +.nf + -dir some/dir -dir other +.fi +will search "some/dir" completely, then search "other" completely. This +is good. However, something like +.nf + -dir some/dir -dir some/dir/more/specific +.fi +will search "some/dir" completely *except for* "some/dir/more/specific", +after which it will return and be searched. Not really a bug, but just sort +of odd. + +File times (for -newer, etc.) of symbolic links are for the file, not the +link. This could cause some misunderstandings. + +Probably more. Please let me know. +.SH AUTHOR +Jeffrey Friedl, Omron Corp (jfriedl@omron.co.jp) +.br +http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html + +.SH "LATEST SOURCE" +See http://www.wg.omron.co.jp/~jfriedl/perl/index.html diff --git a/gnu/usr.bin/perl/win32/bin/webget.pl b/gnu/usr.bin/perl/win32/bin/webget.pl new file mode 100644 index 00000000000..3d72208cb2b --- /dev/null +++ b/gnu/usr.bin/perl/win32/bin/webget.pl @@ -0,0 +1,1091 @@ +#!/usr/local/bin/perl -w + +#- +#!/usr/local/bin/perl -w +$version = "951121.18"; +$comments = 'jfriedl@omron.co.jp'; + +## +## This is "webget" +## +## Jeffrey Friedl (jfriedl@omron.co.jp), July 1994. +## Copyright 19.... ah hell, just take it. +## Should work with either perl4 or perl5 +## +## BLURB: +## Given a URL on the command line (HTTP and FTP supported at the moment), +## webget fetches the named object (HTML text, images, audio, whatever the +## object happens to be). Will automatically use a proxy if one is defined +## in the environment, follow "this URL has moved" responses, and retry +## "can't find host" responses from a proxy in case host lookup was slow). +## Supports users & passwords (FTP), Basic Authorization (HTTP), update-if- +## modified (HTTP), and much more. Works with perl4 or perl5. + +## +## More-detailed instructions in the comment block below the history list. +## + +## +## To-do: +## Add gopher support. +## Fix up how error messages are passed among this and the libraries. +## + +## 951219.19 +## Lost ftp connections now die with a bit more grace. +## +## 951121.18 +## Add -nnab. +## Brought the "usage" string in line with reality. +## +## 951114.17 +## Added -head. +## Added -update/-refresh/-IfNewerThan. If any URL was not pulled +## because it was not out of date, an exit value of 2 is returned. +## +## 951031.16 +## Added -timeout. Cleaned up (a bit) the exit value. Now exits +## with 1 if all URLs had some error (timeout exits immediately with +## code 3, though. This is subject to change). Exits with 0 if any +## URL was brought over safely. +## +## 951017.15 +## Neat -pf, -postfile idea from Lorrie Cranor +## (http://www.ccrc.wustl.edu/~lorracks/) +## +## 950912.14 +## Sigh, fixed a typo. +## +## 950911.13 +## Added Basic Authorization support for http. See "PASSWORDS AND STUFF" +## in the documentation. +## +## 950911.12 +## Implemented a most-excellent suggestion by Anthony D'Atri +## (aad@nwnet.net), to be able to automatically grab to a local file of +## the same name as the URL. See the '-nab' flag. +## +## 950706.11 +## Quelled small -w warning (thanks: Lars Rasmussen <gnort@daimi.aau.dk>) +## +## 950630.10 +## Steve Campbell to the rescue again. FTP now works when supplied +## with a userid & password (eg ftp://user:pass@foo.bar.com/index.txt). +## +## 950623.9 +## Incorporated changes from Steve Campbell (steven_campbell@uk.ibm.com) +## so that the ftp will work when no password is required of a user. +## +## 950530.8 +## Minor changes: +## Eliminate read-size warning message when size unknown. +## Pseudo-debug/warning messages at the end of debug_read now go to +## stderr. Some better error handling when trying to contact systems +## that aren't really set up for ftp. Fixed a bug concerning FTP access +## to a root directory. Added proxy documentation at head of file. +## +## 950426.6,7 +## Complete Overhaul: +## Renamed from httpget. Added ftp support (very sketchy at the moment). +## Redid to work with new 'www.pl' library; chucked 'Www.pl' library. +## More or less new and/or improved in many ways, but probably introduced +## a few bugs along the way. +## +## 941227.5 +## Added follow stuff (with -nofollow, etc.) +## Added -updateme. Cool! +## Some general tidying up. +## +## 941107.4 +## Allowed for ^M ending a header line... PCs give those kind of headers. +## +## 940820.3 +## First sorta'clean net release. +## +## + +## +##> +## +## Fetch http and/or ftp URL(s) given on the command line and spit to +## STDOUT. +## +## Options include: +## -V, -version +## Print version information; exit. +## +## -p, -post +## If the URL looks like a reply to a form (i.e. has a '?' in it), +## the request is POST'ed instead of GET'ed. +## +## -head +## Gets the header only (for HTTP). This might include such useful +## things as 'Last-modified' and 'Content-length' fields +## (a lack of a 'Last-modified' might be a good indication that it's +## a CGI). +## +## The "-head" option implies "-nostrip", but does *not* imply, +## for example "-nofollow". +## +## +## -pf, -postfile +## The item after the '?' is taken as a local filename, and the contents +## are POST'ed as with -post +## +## -nab, -f, -file +## Rather than spit the URL(s) to standard output, unconditionally +## dump to a file (or files) whose name is that as used in the URL, +## sans path. I like '-nab', but supply '-file' as well since that's +## what was originally suggested. Also see '-update' below for the +## only-if-changed version. +## +## -nnab +## Like -nab, but in addtion to dumping to a file, dump to stdout as well. +## Sort of like the 'tee' command. +## +## -update, -refresh +## Do the same thing as -nab, etc., but does not bother pulling the +## URL if it older than the localfile. Only applies to HTTP. +## Uses the HTTP "If-Modified-Since" field. If the URL was not modified +## (and hence not changed), the return value is '2'. +## +## -IfNewerThan FILE +## -int FILE +## Only pulls URLs if they are newer than the date the local FILE was +## last written. +## +## -q, -quiet +## Suppresses all non-essential informational messages. +## +## -nf, -nofollow +## Normally, a "this URL has moved" HTTP response is automatically +## followed. Not done with -nofollow. +## +## -nr, -noretry +## Normally, an HTTP proxy response of "can't find host" is retried +## up to three times, to give the remote hostname lookup time to +## come back with an answer. This suppresses the retries. This is the +## same as '-retry 0'. +## +## -r#, -retry#, -r #, -retry # +## Sets the number of times to retry. Default 3. +## +## -ns, -nostrip +## For HTTP items (including other items going through an HTTP proxy), +## the HTTP response header is printed rather than stripped as default. +## +## -np, -noproxy +## A proxy is not used, even if defined for the protocol. +## +## -h, -help +## Show a usage message and exit. +## +## -d, -debug +## Show some debugging messages. +## +## -updateme +## The special and rather cool flag "-updateme" will see if webget has +## been updated since you got your version, and prepare a local +## version of the new version for you to use. Keep updated! (although +## you can always ask to be put on the ping list to be notified when +## there's a new version -- see the author's perl web page). +## +## -timeout TIMESPAN +## -to TIMESPAN +## Time out if a connection can not be made within the specified time +## period. TIMESPAN is normally in seconds, although a 'm' or 'h' may +## be appended to indicate minutes and hours. "-to 1.5m" would timeout +## after 90 seconds. +## +## (At least for now), a timeout causes immediate program death (with +## exit value 3). For some reason, the alarm doesn't always cause a +## waiting read or connect to abort, so I just die immediately.. /-: +## +## I might consider adding an "entire fetch" timeout, if someone +## wants it. +## +## PASSWORDS AND SUCH +## +## You can use webget to do FTP fetches from non-Anonymous systems and +## accounts. Just put the required username and password into the URL, +## as with +## webget 'ftp:/user:password@ftp.somesite.com/pub/pix/babe.gif +## ^^^^^^^^^^^^^ +## Note the user:password is separated from the hostname by a '@'. +## +## You can use the same kind of thing with HTTP, and if so it will provide +## what's know as Basic Authorization. This is >weak< authorization. It +## also provides >zero< security -- I wouldn't be sending any credit-card +## numbers this way (unless you send them 'round my way :-). It seems to +## be used most by providers of free stuff where they want to make some +## attempt to limit access to "known users". +## +## PROXY STUFF +## +## If you need to go through a gateway to get out to the whole internet, +## you can use a proxy if one's been set up on the gateway. This is done +## by setting the "http_proxy" environmental variable to point to the +## proxy server. Other variables are used for other target protocols.... +## "gopher_proxy", "ftp_proxy", "wais_proxy", etc. +## +## For example, I have the following in my ".login" file (for use with csh): +## +## setenv http_proxy http://local.gateway.machine:8080/ +## +## This is to indicate that any http URL should go to local.gateway.machine +## (port 8080) via HTTP. Additionally, I have +## +## setenv gopher_proxy "$http_proxy" +## setenv wais_proxy "$http_proxy" +## setenv ftp_proxy "$http_proxy" +## +## This means that any gopher, wais, or ftp URL should also go to the +## same place, also via HTTP. This allows webget to get, for example, +## GOPHER URLs even though it doesn't support GOPHER itself. It uses HTTP +## to talk to the proxy, which then uses GOPHER to talk to the destination. +## +## Finally, if there are sites inside your gateway that you would like to +## connect to, you can list them in the "no_proxy" variable. This will allow +## you to connect to them directly and skip going through the proxy: +## +## setenv no_proxy "www.this,www.that,www.other" +## +## I (jfriedl@omron.co.jp) have little personal experience with proxies +## except what I deal with here at Omron, so if this is not representative +## of your situation, please let me know. +## +## RETURN VALUE +## The value returned to the system by webget is rather screwed up because +## I didn't think about dealing with it until things were already +## complicated. Since there can be more than one URL on the command line, +## it's hard to decide what to return when one times out, another is fetched, +## another doesn't need to be fetched, and a fourth isn't found. +## +## So, here's the current status: +## +## Upon any timeout (via the -timeout arg), webget immediately +## returns 3. End of story. Otherwise.... +## +## If any URL was fetched with a date limit (i.e. via +## '-update/-refresh/-IfNewerThan' and was found to not have changed, +## 2 is returned. Otherwise.... +## +## If any URL was successfully fetched, 0 is returned. Otherwise... +## +## If there were any errors, 1 is returned. Otherwise... +## +## Must have been an info-only or do-nothing instance. 0 is returned. +## +## Phew. Hopefully useful to someone. +##< +## + +## Where latest version should be. +$WEB_normal = 'http://www.wg.omron.co.jp/~jfriedl/perl/webget'; +$WEB_inlined = 'http://www.wg.omron.co.jp/~jfriedl/perl/inlined/webget'; + + +require 'network.pl'; ## inline if possible (directive to a tool of mine) +require 'www.pl'; ## inline if possible (directive to a tool of mine) +$inlined=0; ## this might be changed by a the inline thing. + +## +## Exit values. All screwed up. +## +$EXIT_ok = 0; +$EXIT_error = 1; +$EXIT_notmodified = 2; +$EXIT_timeout = 3; + +## +## + +warn qq/WARNING:\n$0: need a newer version of "network.pl"\n/ if + !defined($network'version) || $network'version < "950311.5"; +warn qq/WARNING:\n$0: need a newer version of "www.pl"\n/ if + !defined($www'version) || $www'version < "951114.8"; + +$WEB = $inlined ? $WEB_inlined : $WEB_normal; + +$debug = 0; +$strip = 1; ## default is to strip +$quiet = 0; ## also normally off. +$follow = 1; ## normally, we follow "Found (302)" links +$retry = 3; ## normally, retry proxy hostname lookups up to 3 times. +$nab = 0; ## If true, grab to a local file of the same name. +$refresh = 0; ## If true, use 'If-Modified-Since' with -nab get. +$postfile = 0; ## If true, filename is given after the '?' +$defaultdelta2print = 2048; +$TimeoutSpan = 0; ## seconds after which we should time out. + +while (@ARGV && $ARGV[0] =~ m/^-/) +{ + $arg = shift(@ARGV); + + $nab = 1, next if $arg =~ m/^-f(ile)?$/; + $nab = 1, next if $arg =~ m/^-nab$/; + $nab = 2, next if $arg =~ m/^-nnab$/; + $post = 1, next if $arg =~ m/^-p(ost)?$/i; + $post = $postfile = 1, next if $arg =~ m/^-p(ost)?f(ile)?$/i; + $quiet=1, next if $arg =~ m/^-q(uiet)?$/; + $follow = 0, next if $arg =~ m/^-no?f(ollow)?$/; + $strip = 0, next if $arg =~ m/^-no?s(trip)?$/; + $debug=1, next if $arg =~ m/^-d(ebug)?$/; + $noproxy=1, next if $arg =~ m/^-no?p(roxy)?$/; + $retry=0, next if $arg =~ m/^-no?r(etry)?$/; + $retry=$2, next if $arg =~ m/^-r(etry)?(\d+)$/; + &updateme if $arg eq '-updateme'; + $strip = 0, $head = 1, next if $arg =~ m/^-head(er)?/; + $nab = $refresh = 1, next if $arg =~ m/^-(refresh|update)/; + + &usage($EXIT_ok) if $arg =~ m/^-h(elp)?$/; + &show_version, exit($EXIT_ok) if $arg eq '-version' || $arg eq '-V'; + + if ($arg =~ m/^-t(ime)?o(ut)?$/i) { + local($num) = shift(@ARGV); + &usage($EXIT_error, "expecting timespan argument to $arg\n") unless + $num =~ m/^\d+(\d*)?[hms]?$/; + &timeout_arg($num); + next; + } + + if ($arg =~ m/^-if?n(ewer)?t(han)?$/i) { + $reference_file = shift(@ARGV); + &usage($EXIT_error, "expecting filename arg to $arg") + if !defined $reference_file; + if (!-f $reference_file) { + warn qq/$0: ${arg}'s "$reference_file" not found.\n/; + exit($EXIT_error); + } + next; + } + + if ($arg eq '-r' || $arg eq '-retry') { + local($num) = shift(@ARGV); + &usage($EXIT_error, "expecting numerical arg to $arg\n") unless + defined($num) && $num =~ m/^\d+$/; + $retry = $num; + next; + } + &usage($EXIT_error, qq/$0: unknown option "$arg"\n/); +} + +if ($head && $post) { + warn "$0: combining -head and -post makes no sense, ignoring -post.\n"; + $post = 0; + undef $postfile; +} + +if ($refresh && defined($reference_file)) { + warn "$0: combining -update and -IfNewerThan make no sense, ignoring -IfNewerThan.\n"; + undef $reference_file; +} + +if (@ARGV == 0) { + warn "$0: nothing to do. Use -help for info.\n"; + exit($EXIT_ok); +} + + +## +## Now run through the remaining arguments (mostly URLs) and do a quick +## check to see if they look well-formed. We won't *do* anything -- just +## want to catch quick errors before really starting the work. +## +@tmp = @ARGV; +$errors = 0; +while (@tmp) { + $arg = shift(@tmp); + if ($arg =~ m/^-t(ime)?o(ut)?$/) { + local($num) = shift(@tmp); + if ($num !~ m/^\d+(\d*)?[hms]?$/) { + &warn("expecting timespan argument to $arg\n"); + $errors++; + } + } else { + local($protocol) = &www'grok_URL($arg, $noproxy); + + if (!defined $protocol) { + warn qq/can't grok "$arg"/; + $errors++; + } elsif (!$quiet && ($protocol eq 'ftp')) { + warn qq/warning: -head ignored for ftp URLs\n/ if $head; + warn qq/warning: -refresh ignored for ftp URLs\n/if $refresh; + warn qq/warning: -IfNewerThan ignored for ftp URLs\n/if defined($reference_file); + + } + } +} + +exit($EXIT_error) if $errors; + + +$SuccessfulCount = 0; +$NotModifiedCount = 0; + +## +## Now do the real thing. +## +while (@ARGV) { + $arg = shift(@ARGV); + if ($arg =~ m/^-t(ime)?o(ut)?$/) { + &timeout_arg(shift(@ARGV)); + } else { + &fetch_url($arg); + } +} + +if ($NotModifiedCount) { + exit($EXIT_notmodified); +} elsif ($SuccessfulCount) { + exit($EXIT_ok); +} else { + exit($EXIT_error); +} + +########################################################################### +########################################################################### + +sub timeout_arg +{ + ($TimeoutSpan) = @_; + $TimeoutSpan =~ s/s//; + $TimeoutSpan *= 60 if $TimeoutSpan =~ m/m/; + $TimeoutSpan *= 3600 if $TimeoutSpan =~ m/h/; + +} + +## +## As a byproduct, returns the basename of $0. +## +sub show_version +{ + local($base) = $0; + $base =~ s,.*/,,; + print STDERR "This is $base version $version\n"; + $base; +} + +## +## &usage(exitval, message); +## +## Prints a usage message to STDERR. +## If MESSAGE is defined, prints that first. +## If exitval is defined, exits with that value. Otherwise, returns. +## +sub usage +{ + local($exit, $message) = @_; + + print STDERR $message if defined $message; + local($base) = &show_version; + print STDERR <<INLINE_LITERAL_TEXT; +usage: $0 [options] URL ... + Fetches and displays the named URL(s). Supports http and ftp. + (if no protocol is given, a leading "http://" is normally used). + +Options are from among: + -V, -version Print version information; exit. + -p, -post If URL looks like a form reply, does POST instead of GET. + -pf, -postfile Like -post, but takes everything after ? to be a filename. + -q, -quiet All non-essential informational messages are suppressed. + -nf, -nofollow Don't follow "this document has moved" replies. + -nr, -noretry Doesn't retry a failed hostname lookup (same as -retry 0) + -r #, -retry # Sets failed-hostname-lookup-retry to # (default $retry) + -np, -noproxy Uses no proxy, even if one defined for the protocol. + -ns, -nostrip The HTTP header, normally elided, is printed. + -head gets item header only (implies -ns) + -nab, -file Dumps output to file whose name taken from URL, minus path + -nnab Like -nab, but *also* dumps to stdout. + -update HTTP only. Like -nab, but only if the page has been modified. + -h, -help Prints this message. + -IfNewerThan F HTTP only. Only brings page if it is newer than named file. + -timeout T Fail if a connection can't be made in the specified time. + + -updateme Pull the latest version of $base from + $WEB + and reports if it is newer than your current version. + +Comments to $comments. +INLINE_LITERAL_TEXT + + exit($exit) if defined $exit; +} + +## +## Pull the latest version of this program to a local file. +## Clip the first couple lines from this executing file so that we +## preserve the local invocation style. +## +sub updateme +{ + ## + ## Open a temp file to hold the new version, + ## redirecting STDOUT to it. + ## + open(STDOUT, '>'.($tempFile="/tmp/webget.new")) || + open(STDOUT, '>'.($tempFile="/usr/tmp/webget.new")) || + open(STDOUT, '>'.($tempFile="/webget.new")) || + open(STDOUT, '>'.($tempFile="webget.new")) || + die "$0: can't open a temp file.\n"; + + ## + ## See if we can figure out how we were called. + ## The seek will rewind not to the start of the data, but to the + ## start of the whole program script. + ## + ## Keep the first line if it begins with #!, and the next two if they + ## look like the trick mentioned in the perl man page for getting + ## around the lack of #!-support. + ## + if (seek(DATA, 0, 0)) { ## + $_ = <DATA>; if (m/^#!/) { print STDOUT; + $_ = <DATA>; if (m/^\s*eval/) { print STDOUT; + $_ = <DATA>; if (m/^\s*if/) { print STDOUT; } + } + } + print STDOUT "\n#-\n"; + } + + ## Go get the latest one... + local(@options); + push(@options, 'head') if $head; + push(@options, 'nofollow') unless $follow; + push(@options, ('retry') x $retry) if $retry; + push(@options, 'quiet') if $quiet; + push(@options, 'debug') if $debug; + local($status, $memo, %info) = &www'open_http_url(*IN, $WEB, @options); + die "fetching $WEB:\n $memo\n" unless $status eq 'ok'; + + $size = $info{'content-length'}; + while (<IN>) + { + $size -= length; + print STDOUT; + if (!defined $fetched_version && m/version\s*=\s*"([^"]+)"/) { + $fetched_version = $1; + &general_read(*IN, $size); + last; + } + } + + $fetched_version = "<unknown>" unless defined $fetched_version; + + ## + ## Try to update the mode of the temp file with the mode of this file. + ## Don't worry if it fails. + ## + chmod($mode, $tempFile) if $mode = (stat($0))[2]; + + $as_well = ''; + if ($fetched_version eq $version) + { + print STDERR "You already have the most-recent version ($version).\n", + qq/FWIW, the newly fetched one has been left in "$tempFile".\n/; + } + elsif ($fetched_version <= $version) + { + print STDERR + "Mmm, your current version seems newer (?!):\n", + qq/ your version: "$version"\n/, + qq/ new version: "$fetched_version"\n/, + qq/FWIW, fetched one left in "$tempFile".\n/; + } + else + { + print STDERR + "Indeed, your current version was old:\n", + qq/ your version: "$version"\n/, + qq/ new version: "$fetched_version"\n/, + qq/The file "$tempFile" is ready to replace the old one.\n/; + print STDERR qq/Just do:\n % mv $tempFile $0\n/ if -f $0; + $as_well = ' as well'; + } + print STDERR "Note that the libraries it uses may (or may not) need updating$as_well.\n" + unless $inlined; + exit($EXIT_ok); +} + +## +## Given a list of URLs, fetch'em. +## Parses the URL and calls the routine for the appropriate protocol +## +sub fetch_url +{ + local(@todo) = @_; + local(%circref, %hold_circref); + + URL_LOOP: while (@todo) + { + $URL = shift(@todo); + %hold_circref = %circref; undef %circref; + + local($protocol, @args) = &www'grok_URL($URL, $noproxy); + + if (!defined $protocol) { + &www'message(1, qq/can't grok "$URL"/); + next URL_LOOP; + } + + ## call protocol-specific handler + $func = "fetch_via_" . $protocol; + $error = &$func(@args, $TimeoutSpan); + if (defined $error) { + &www'message(1, "$URL: $error"); + } else { + $SuccessfulCount++; + } + } +} + +sub filedate +{ + local($filename) = @_; + local($filetime) = (stat($filename))[9]; + return 0 if !defined $filetime; + local($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($filetime); + return 0 if !defined $wday; + sprintf(qq/"%s, %02d-%s-%02d %02d:%02d:%02d GMT"/, + ("Sunday", "Monday", "Tuesdsy", "Wednesday", + "Thursday", "Friday", "Saturday")[$wday], + $mday, + ("Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")[$mon], + $year, + $hour, + $min, + $sec); +} + +sub local_filename +{ + local($filename) = @_; + $filename =~ s,/+$,,; ## remove any trailing slashes + $filename =~ s,.*/,,; ## remove any leading path + if ($filename eq '') { + ## empty -- pick a random name + $filename = "file0000"; + ## look for a free random name. + $filename++ while -f $filename; + } + $filename; +} + +sub set_output_file +{ + local($filename) = @_; + if (!open(OUT, ">$filename")) { + &www'message(1, "$0: can't open [$filename] for output"); + } else { + open(SAVEOUT, ">>&STDOUT") || die "$!";; + open(STDOUT, ">>&OUT"); + } +} + +sub close_output_file +{ + local($filename) = @_; + unless ($quiet) + { + local($note) = qq/"$filename" written/; + if (defined $error) { + $note .= " (possibly corrupt due to error above)"; + } + &www'message(1, "$note."); + } + close(STDOUT); + open(STDOUT, ">&SAVEOUT"); +} + +sub http_alarm +{ + &www'message(1, "ERROR: $AlarmNote."); + exit($EXIT_timeout); ## the alarm doesn't seem to cause a waiting syscall to break? +# $HaveAlarm = 1; +} + +## +## Given the host, port, and path, and (for info only) real target, +## fetch via HTTP. +## +## If there is a user and/or password, use that for Basic Authorization. +## +## If $timeout is nonzero, time out after that many seconds. +## +sub fetch_via_http +{ + local($host, $port, $path, $target, $user, $password, $timeout) = @_; + local(@options); + local($local_filename); + + ## + ## If we're posting, but -postfile was given, we need to interpret + ## the item in $path after '?' as a filename, and replace it with + ## the contents of the file. + ## + if ($postfile && $path =~ s/\?([\d\D]*)//) { + local($filename) = $1; + return("can't open [$filename] to POST") if !open(IN, "<$filename"); + local($/) = ''; ## want to suck up the whole file. + $path .= '?' . <IN>; + close(IN); + } + + $local_filename = &local_filename($path) + if $refresh || $nab || defined($reference_file); + $refresh = &filedate($local_filename) if $refresh; + $refresh = &filedate($reference_file) if defined($reference_file); + + push(@options, 'head') if $head; + push(@options, 'post') if $post; + push(@options, 'nofollow') unless $follow; + push(@options, ('retry') x 3); + push(@options, 'quiet') if $quiet; + push(@options, 'debug') if $debug; + push(@options, "ifmodifiedsince=$refresh") if $refresh; + + if (defined $password || defined $user) { + local($auth) = join(':', ($user || ''), ($password || '')); + push(@options, "authorization=$auth"); + } + + local($old_alarm); + if ($timeout) { + $old_alarm = $SIG{'ALRM'} || 'DEFAULT'; + $SIG{'ALRM'} = "main'http_alarm"; +# $HaveAlarm = 0; + $AlarmNote = "host $host"; + $AlarmNote .= ":$port" if $port != $www'default_port{'http'}; + $AlarmNote .= " timed out after $timeout second"; + $AlarmNote .= 's' if $timeout > 1; + alarm($timeout); + } + local($result, $memo, %info) = + &www'open_http_connection(*HTTP, $host,$port,$path,$target,@options); + + if ($timeout) { + alarm(0); + $SIG{'ALRM'} = $old_alarm; + } + +# if ($HaveAlarm) { +# close(HTTP); +# $error = "timeout after $timeout second"; +# $error .= "s" if $timeout > 1; +# return $error; +# } + + if ($follow && ($result eq 'follow')) { + %circref = %hold_circref; + $circref{$memo} = 1; + unshift(@todo, $memo); + return undef; + } + + + return $memo if $result eq 'error'; + if (!$quiet && $result eq 'status' && ! -t STDOUT) { + #&www'message(1, "Warning: $memo"); + $error = "Warning: $memo"; + } + + if ($info{'CODE'} == 304) { ## 304 is magic for "Not Modified" + close(HTTP); + &www'message(1, "$URL: Not Modified") unless $quiet; + $NotModifiedCount++; + return undef; ## no error + } + + + &set_output_file($local_filename) if $nab; + + unless($strip) { + print $info{'STATUS'}, "\n", $info{'HEADER'}, "\n"; + + print SAVEOUT $info{'STATUS'}, "\n", $info{'HEADER'}, "\n" if $nab==2; + } + + if (defined $info{'BODY'}) { + print $info{'BODY'}; + print SAVEOUT $info{'BODY'} if $nab==2; + } + + if (!$head) { + &general_read(*HTTP, $info{'content-length'}); + } + close(HTTP); + &close_output_file($local_filename) if $nab; + + $error; ## will be 'undef' if no error; +} + +sub fetch_via_ftp +{ + local($host, $port, $path, $target, $user, $password, $timeout) = @_; + local($local_filename) = &local_filename($path); + local($ftp_debug) = $debug; + local(@password) = ($password); + $path =~ s,^/,,; ## remove a leading / from the path. + $path = '.' if $path eq ''; ## make sure we have something + + if (!defined $user) { + $user = 'anonymous'; + $password = $ENV{'USER'} || 'WWWuser'; + @password = ($password.'@'. &network'addr_to_ascii(&network'my_addr), + $password.'@'); + } elsif (!defined $password) { + @password = (""); + } + + local($_last_ftp_reply, $_passive_host, $_passive_port); + local($size); + + sub _ftp_get_reply + { + local($text) = scalar(<FTP_CONTROL>); + die "lost connection to $host\n" if !defined $text; + local($_, $tmp); + print STDERR "READ: $text" if $ftp_debug; + die "internal error: expected reply code in response from ". + "ftp server [$text]" unless $text =~ s/^(\d+)([- ])//; + local($code) = $1; + if ($2 eq '-') { + while (<FTP_CONTROL>) { + ($tmp = $_) =~ s/^\d+[- ]//; + $text .= $tmp; + last if m/^$code /; + } + } + $text =~ s/^\d+ ?/<foo>/g; + ($code, $text); + } + + sub _ftp_expect + { + local($code, $text) = &_ftp_get_reply; + $_last_ftp_reply = $text; + foreach $expect (@_) { + return ($code, $text) if $code == $expect; + } + die "internal error: expected return code ". + join('|',@_).", got [$text]"; + } + + sub _ftp_send + { + print STDERR "SEND: ", @_ if $ftp_debug; + print FTP_CONTROL @_; + } + + sub _ftp_do_passive + { + local(@commands) = @_; + + &_ftp_send("PASV\r\n"); + local($code) = &_ftp_expect(227, 125); + + if ($code == 227) + { + die "internal error: can't grok passive reply [$_last_ftp_reply]" + unless $_last_ftp_reply =~ m/\(([\d,]+)\)/; + local($a,$b,$c,$d, $p1, $p2) = split(/,/, $1); + ($_passive_host, $_passive_port) = + ("$a.$b.$c.$d", $p1*256 + $p2); + } + + foreach(@commands) { + &_ftp_send($_); + } + + local($error)= + &network'connect_to(*PASSIVE, $_passive_host, $_passive_port); + die "internal error: passive ftp connect [$error]" if $error; + } + + ## make the connection to the host + &www'message($debug, "connecting to $host...") unless $quiet; + + local($old_alarm); + if ($timeout) { + $old_alarm = $SIG{'ALRM'} || 'DEFAULT'; + $SIG{'ALRM'} = "main'http_alarm"; ## can use this for now +# $HaveAlarm = 0; + $AlarmNote = "host $host"; + $AlarmNote .= ":$port" if $port != $www'default_port{'ftp'}; + $AlarmNote .= " timed out after $timeout second"; + $AlarmNote .= 's' if $timeout > 1; + alarm($timeout); + } + + local($error) = &network'connect_to(*FTP_CONTROL, $host, $port); + + if ($timeout) { + alarm(0); + $SIG{'ALRM'} = $old_alarm; + } + + return $error if $error; + + local ($code, $text) = &_ftp_get_reply(*FTP_CONTROL); + close(FTP_CONTROL), return "internal ftp error: [$text]" unless $code==220; + + ## log in + &www'message($debug, "logging in as $user...") unless $quiet; + foreach $password (@password) + { + &_ftp_send("USER $user\r\n"); + ($code, $text) = &_ftp_expect(230,331,530); + close(FTP_CONTROL), return $text if ($code == 530); + last if $code == 230; ## hey, already logged in, cool. + + &_ftp_send("PASS $password\r\n"); + ($code, $text) = &_ftp_expect(220,230,530,550,332); + last if $code != 550; + last if $text =~ m/can't change directory/; + } + + if ($code == 550) + { + $text =~ s/\n+$//; + &www'message(1, "Can't log in $host: $text") unless $quiet; + exit($EXIT_error); + } + + if ($code == 332) + { + &_ftp_send("ACCT noaccount\r\n"); + ($code, $text) = &_ftp_expect(230, 202, 530, 500,501,503, 421) + } + close(FTP_CONTROL), return $text if $code >= 300; + + &_ftp_send("TYPE I\r\n"); + &_ftp_expect(200); + + unless ($quiet) { + local($name) = $path; + $name =~ s,.*/([^/]),$1,; + &www'message($debug, "requesting $name..."); + } + ## get file + &_ftp_do_passive("RETR $path\r\n"); + ($code,$text) = &_ftp_expect(125, 150, 550, 530); + close(FTP_CONTROL), return $text if $code == 530; + + if ($code == 550) + { + close(PASSIVE); + if ($text =~ /directory/i) { + ## probably from "no such file or directory", so just return now. + close(FTP_CONTROL); + return $text; + } + + ## do like Mosaic and try getting a directory listing. + &_ftp_send("CWD $path\r\n"); + ($code) = &_ftp_expect(250,550); + if ($code == 550) { + close(FTP_CONTROL); + return $text; + } + &_ftp_do_passive("LIST\r\n"); + &_ftp_expect(125, 150); + } + + $size = $1 if $text =~ m/(\d+)\s+bytes/; + binmode(PASSIVE); ## just in case. + &www'message($debug, "waiting for data...") unless $quiet; + &set_output_file($local_filename) if $nab; + &general_read(*PASSIVE, $size); + &close_output_file($local_filename) if $nab; + + close(PASSIVE); + close(FTP_CONTROL); + undef; +} + +sub general_read +{ + local(*INPUT, $size) = @_; + local($lastcount, $bytes) = (0,0); + local($need_to_clear) = 0; + local($start_time) = time; + local($last_time, $time) = $start_time; + ## Figure out how often to print the "bytes read" message + local($delta2print) = + (defined $size) ? int($size/50) : $defaultdelta2print; + + &www'message(0, "read 0 bytes") unless $quiet; + + ## so $! below is set only if a real error happens from now + eval 'local($^W) = 0; undef $!'; + + + while (defined($_ = <INPUT>)) + { + ## shove it out. + &www'clear_message if $need_to_clear; + print; + print SAVEOUT if $nab==2; + + ## if we know the content-size, keep track of what we're reading. + $bytes += length; + + last if eof || (defined $size && $bytes >= $size); + + if (!$quiet && $bytes > ($lastcount + $delta2print)) + { + if ($time = time, $last_time == $time) { + $delta2print *= 1.5; + } else { + $last_time = $time; + $lastcount = $bytes; + local($time_delta) = $time - $start_time; + local($text); + + $delta2print /= $time_delta; + if (defined $size) { + $text = sprintf("read $bytes bytes (%.0f%%)", + $bytes*100/$size); + } else { + $text = "read $bytes bytes"; + } + + if ($time_delta > 5 || ($time_delta && $bytes > 10240)) + { + local($rate) = int($bytes / $time_delta); + if ($rate < 5000) { + $text .= " ($rate bytes/sec)"; + } elsif ($rate < 1024 * 10) { + $text .= sprintf(" (%.1f k/sec)", $rate/1024); + } else { + $text .= sprintf(" (%.0f k/sec)", $rate/1024); + } + } + &www'message(0, "$text..."); + $need_to_clear = -t STDOUT; + } + } + } + + if (!$quiet) + { + if ($size && ($size != $bytes)) { + &www'message("WARNING: Expected $size bytes, read $bytes bytes.\n"); + } +# if ($!) { +# print STDERR "\$! is [$!]\n"; +# } +# if ($@) { +# print STDERR "\$\@ is [$@]\n"; +# } + } + &www'clear_message($text) unless $quiet; +} + +sub dummy { + 1 || &dummy || &fetch_via_ftp || &fetch_via_http || &http_alarm; + 1 || close(OUT); + 1 || close(SAVEOUT); +} + +__END__ diff --git a/gnu/usr.bin/perl/win32/bin/www.pl b/gnu/usr.bin/perl/win32/bin/www.pl new file mode 100644 index 00000000000..8022597454b --- /dev/null +++ b/gnu/usr.bin/perl/win32/bin/www.pl @@ -0,0 +1,901 @@ +## +## Jeffrey Friedl (jfriedl@omron.co.jp) +## Copyri.... ah hell, just take it. +## +## This is "www.pl". +## Include (require) to use, execute ("perl www.pl") to print a man page. +## Requires my 'network.pl' library. +package www; +$version = "951219.9"; + +## +## 951219.9 +## -- oops, stopped sending garbage Authorization line when no +## authorization was requested. +## +## 951114.8 +## -- added support for HEAD, If-Modified-Since +## +## 951017.7 +## -- Change to allow a POST'ed HTTP text to have newlines in it. +## Added 'NewURL to the open_http_connection %info. Idea courtesy +## of Bryan Schmersal (http://www.transarc.com/~bryans/Home.html). +## +## +## 950921.6 +## -- added more robust HTTP error reporting +## (due to steven_campbell@uk.ibm.com) +## +## 950911.5 +## -- added Authorization support +## + +## +## HTTP return status codes. +## +%http_return_code = + (200,"OK", + 201,"Created", + 202,"Accepted", + 203,"Partial Information", + 204,"No Response", + 301,"Moved", + 302,"Found", + 303,"Method", + 304,"Not modified", + 400,"Bad request", + 401,"Unauthorized", + 402,"Payment required", + 403,"Forbidden", + 404,"Not found", + 500,"Internal error", + 501,"Not implemented", + 502,"Service temporarily overloaded", + 503,"Gateway timeout"); + +## +## If executed directly as a program, print as a man page. +## +if (length($0) >= 6 && substr($0, -6) eq 'www.pl') +{ + seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n"; + print "www.pl version $version\n", '=' x 60, "\n"; + while (<DATA>) { + next unless /^##>/../^##</; ## select lines to print + s/^##[<> ]?//; ## clean up + print; + } + exit(0); +} + +## +## History: +## version 950425.4 +## added require for "network.pl" +## +## version 950425.3 +## re-did from "Www.pl" which was a POS. +## +## +## BLURB: +## A group of routines for dealing with URLs, HTTP sessions, proxies, etc. +## Requires my 'network.pl' package. The library file can be executed +## directly to produce a man page. + +##> +## A motley group of routines for dealing with URLs, HTTP sessions, proxies, +## etc. Requires my 'network.pl' package. +## +## Latest version, as well as other stuff (including network.pl) available +## at http://www.wg.omron.co.jp/~jfriedl/perl/ +## +## Simpleton complete program to dump a URL given on the command-line: +## +## require 'network.pl'; ## required for www.pl +## require 'www.pl'; ## main routines +## $URL = shift; ## get URL +## ($status, $memo) = &www'open_http_url(*IN, $URL); ## connect +## die "$memo\n" if $status ne 'ok'; ## report any error +## print while <IN>; ## dump contents +## +## There are various options available for open_http_url. +## For example, adding 'quiet' to the call, i.e. vvvvvvv-----added +## ($status, $memo) = &www'open_http_url(*IN, $URL, 'quiet'); +## suppresses the normal informational messages such as "waiting for data...". +## +## The options, as well as the various other public routines in the package, +## are discussed below. +## +##< + +## +## Default port for the protocols whose URL we'll at least try to recognize. +## +%default_port = ('http', 80, + 'ftp', 21, + 'gopher', 70, + 'telnet', 23, + 'wais', 210, + ); + +## +## A "URL" to "ftp.blah.com" without a protocol specified is probably +## best reached via ftp. If the hostname begins with a protocol name, it's +## easy. But something like "www." maps to "http", so that mapping is below: +## +%name2protocol = ( + 'www', 'http', + 'wwwcgi','http', +); + +$last_message_length = 0; +$useragent = "www.pl/$version"; + +## +##> +############################################################################## +## routine: open_http_url +## +## Used as +## ($status, $memo, %info) = &www'open_http_url(*FILEHANDLE, $URL, options..) +## +## Given an unused filehandle, a URL, and a list of options, opens a socket +## to the URL and returns with the filehandle ready to read the data of the +## URL. The HTTP header, as well as other information, is returned in %info. +## +## OPTIONS are from among: +## +## "post" +## If PATH appears to be a query (i.e. has a ? in it), contact +## via a POST rather than a GET. +## +## "nofollow" +## Normally, if the initial contact indicates that the URL has moved +## to a different location, the new location is automatically contacted. +## "nofollow" inhibits this. +## +## "noproxy" +## Normally, a proxy will be used if 'http_proxy' is defined in the +## environment. This option inhibits the use of a proxy. +## +## "retry" +## If a host's address can't be found, it may well be because the +## nslookup just didn't return in time and that retrying the lookup +## after a few seconds will succeed. If this option is given, will +## wait five seconds and try again. May be given multiple times to +## retry multiple times. +## +## "quiet" +## Informational messages will be suppressed. +## +## "debug" +## Additional messages will be printed. +## +## "head" +## Requests only the file header to be sent +## +## +## +## +## The return array is ($STATUS, $MEMO, %INFO). +## +## STATUS is 'ok', 'error', 'status', or 'follow' +## +## If 'error', the MEMO will indicate why (URL was not http, can't +## connect, etc.). INFO is probably empty, but may have some data. +## See below. +## +## If 'status', the connnection was made but the reply was not a normal +## "OK" successful reply (i.e. "Not found", etc.). MEMO is a note. +## INFO is filled as noted below. Filehandle is ready to read (unless +## $info{'BODY'} is filled -- see below), but probably most useful +## to treat this as an 'error' response. +## +## If 'follow', MEMO is the new URL (for when 'nofollow' was used to +## turn off automatic following) and INFO is filled as described +## below. Unless you wish to give special treatment to these types of +## responses, you can just treat 'follow' responses like 'ok' +## responses. +## +## If 'ok', the connection went well and the filehandle is ready to +## read. +## +## INFO contains data as described at the read_http_header() function (in +## short, the HTTP response header) and additional informational fields. +## In addition, the following fields are filled in which describe the raw +## connection made or attempted: +## +## PROTOCOL, HOST, PORT, PATH +## +## Note that if a proxy is being used, these will describe the proxy. +## The field TARGET will describe the host or host:port ultimately being +## contacted. When no proxy is being used, this will be the same info as +## in the raw connection fields above. However, if a proxy is being used, +## it will refer to the final target. +## +## In some cases, the additional entry $info{'BODY'} exists as well. If +## the result-code indicates an error, the body of the message may be +## parsed for internal reasons (i.e. to support 'repeat'), and if so, it +## will be saved in $info{'BODY}. +## +## If the URL has moved, $info{'NewURL'} will exist and contain the new +## URL. This will be true even if the 'nofollow' option is specified. +## +##< +## +sub open_http_url +{ + local(*HTTP, $URL, @options) = @_; + return &open_http_connection(*HTTP, $URL, undef, undef, undef, @options); +} + + +## +##> +############################################################################## +## routine: read_http_header +## +## Given a filehandle to a just-opened HTTP socket connection (such as one +## created via &network'connect_to which has had the HTTP request sent), +## reads the HTTP header and and returns the parsed info. +## +## ($replycode, %info) = &read_http_header(*FILEHANDLE); +## +## $replycode will be the HTTP reply code as described below, or +## zero on header-read error. +## +## %info contains two types of fields: +## +## Upper-case fields are informational from the function. +## Lower-case fields are the header field/value pairs. +## +## Upper-case fields: +## +## $info{'STATUS'} will be the first line read (HTTP status line) +## +## $info{'CODE'} will be the numeric HTTP reply code from that line. +## This is also returned as $replycode. +## +## $info{'TYPE'} is the text from the status line that follows CODE. +## +## $info{'HEADER'} will be the raw text of the header (sans status line), +## newlines and all. +## +## $info{'UNKNOWN'}, if defined, will be any header lines not in the +## field/value format used to fill the lower-case fields of %info. +## +## Lower-case fields are reply-dependent, but in general are described +## in http://info.cern.ch/hypertext/WWW/Protocols/HTTP/Object_Headers.html +## +## A header line such as +## Content-type: Text/Plain +## will appear as $info{'content-type'} = 'Text/Plain'; +## +## (*) Note that while the field names are are lower-cased, the field +## values are left as-is. +## +## +## When $replycode is zero, there are two possibilities: +## $info{'TYPE'} is 'empty' +## No response was received from the filehandle before it was closed. +## No other %info fields present. +## $info{'TYPE'} is 'unknown' +## First line of the response doesn't seem to be proper HTTP. +## $info{'STATUS'} holds that line. No other %info fields present. +## +## The $replycode, when not zero, is as described at +## http://info.cern.ch/hypertext/WWW/Protocols/HTTP/HTRESP.html +## +## Some of the codes: +## +## success 2xx +## ok 200 +## created 201 +## accepted 202 +## partial information 203 +## no response 204 +## redirection 3xx +## moved 301 +## found 302 +## method 303 +## not modified 304 +## error 4xx, 5xx +## bad request 400 +## unauthorized 401 +## paymentrequired 402 +## forbidden 403 +## not found 404 +## internal error 500 +## not implemented 501 +## service temporarily overloaded 502 +## gateway timeout 503 +## +##< +## +sub read_http_header +{ + local(*HTTP) = @_; + local(%info, $_); + + ## + ## The first line of the response will be the status (OK, error, etc.) + ## + unless (defined($info{'STATUS'} = <HTTP>)) { + $info{'TYPE'} = "empty"; + return (0, %info); + } + chop $info{'STATUS'}; + + ## + ## Check the status line. If it doesn't match and we don't know the + ## format, we'll just let it pass and hope for the best. + ## + unless ($info{'STATUS'} =~ m/^HTTP\S+\s+(\d\d\d)\s+(.*\S)/i) { + $info{'TYPE'} = 'unknown'; + return (0, %info); + } + + $info{'CODE'} = $1; + $info{'TYPE'} = $2; + $info{'HEADER'} = ''; + + ## read the rest of the header. + while (<HTTP>) { + last if m/^\s*$/; + $info{'HEADER'} .= $_; ## save whole text of header. + + if (m/^([^\n:]+):[ \t]*(.*\S)/) { + local($field, $value) = ("\L$1", $2); + if (defined $info{$field}) { + $info{$field} .= "\n" . $value; + } else { + $info{$field} = $value; + } + } elsif (defined $info{'UNKNOWN'}) { + $info{'UNKNOWN'} .= $_; + } else { + $info{'UNKNOWN'} = $_; + } + } + + return ($info{'CODE'}, %info); +} + +## +##> +## +############################################################################## +## routine: grok_URL(URL, noproxy, defaultprotocol) +## +## Given a URL, returns access information. Deals with +## http, wais, gopher, ftp, and telnet +## URLs. +## +## Information returned is +## (PROTOCOL, HOST, PORT, PATH, TARGET, USER, PASSWORD) +## +## If noproxy is not given (or false) and there is a proxy defined +## for the given protocol (via the "*_proxy" environmental variable), +## the returned access information will be for the proxy and will +## reference the given URL. In this case, 'TARGET' will be the +## HOST:PORT of the original URL (PORT elided if it's the default port). +## +## Access information returned: +## PROTOCOL: "http", "ftp", etc. (guaranteed to be lowercase). +## HOST: hostname or address as given. +## PORT: port to access +## PATH: path of resource on HOST:PORT. +## TARGET: (see above) +## USER and PASSWORD: for 'ftp' and 'telnet' URLs, if supplied by the +## URL these will be defined, undefined otherwise. +## +## If no protocol is defined via the URL, the defaultprotocol will be used +## if given. Otherwise, the URL's address will be checked for a leading +## protocol name (as with a leading "www.") and if found will be used. +## Otherwise, the protocol defaults to http. +## +## Fills in the appropriate default port for the protocol if need be. +## +## A proxy is defined by a per-protocol environmental variable such +## as http_proxy. For example, you might have +## setenv http_proxy http://firewall:8080/ +## setenv ftp_proxy $http_proxy +## to set it up. +## +## A URL seems to be officially described at +## http://www.w3.org/hypertext/WWW/Addressing/URL/5_BNF.html +## although that document is a joke of errors. +## +##< +## +sub grok_URL +{ + local($_, $noproxy, $defaultprotocol) = @_; + $noproxy = defined($noproxy) && $noproxy; + + ## Items to be filled in and returned. + local($protocol, $address, $port, $path, $target, $user, $password); + + return undef unless m%^(([a-zA-Z]+)://|/*)([^/]+)(/.*)?$%; + + ## + ## Due to a bug in some versions of perl5, $2 might not be empty + ## even if $1 is. Therefore, we must check $1 for a : to see if the + ## protocol stuff matched or not. If not, the protocol is undefined. + ## + ($protocol, $address, $path) = ((index($1,":") >= 0 ? $2 : undef), $3, $4); + + if (!defined $protocol) + { + ## + ## Choose a default protocol if none given. If address begins with + ## a protocol name (one that we know via %name2protocol or + ## %default_port), choose it. Otherwise, choose http. + ## + if (defined $defaultprotocol) { + $protocol = $defaultprotocol; + } + else + { + $address =~ m/^[a-zA-Z]+/; + if (defined($name2protocol{"\L$&"})) { + $protocol = $name2protocol{"\L$&"}; + } else { + $protocol = defined($default_port{"\L$&"}) ? $& : 'http'; + } + } + } + $protocol =~ tr/A-Z/a-z/; ## ensure lower-case. + + ## + ## Http support here probably not kosher, but fits in nice for basic + ## authorization. + ## + if ($protocol eq 'ftp' || $protocol eq 'telnet' || $protocol eq 'http') + { + ## Glean a username and password from address, if there. + ## There if address starts with USER[:PASSWORD]@ + if ($address =~ s/^(([^\@:]+)(:([^@]+))?\@)//) { + ($user, $password) = ($2, $4); + } + } + + ## + ## address left is (HOSTNAME|HOSTNUM)[:PORTNUM] + ## + if ($address =~ s/:(\d+)$//) { + $port = $1; + } else { + $port = $default_port{$protocol}; + } + + ## default path is '/'; + $path = '/' if !defined $path; + + ## + ## If there's a proxy and we're to proxy this request, do so. + ## + local($proxy) = $ENV{$protocol."_proxy"}; + if (!$noproxy && defined($proxy) && !&no_proxy($protocol,$address)) + { + local($dummy); + local($old_pass, $old_user); + + ## + ## Since we're going through a proxy, we want to send the + ## proxy the entire URL that we want. However, when we're + ## doing Authenticated HTTP, we need to take out the user:password + ## that webget has encoded in the URL (this is a bit sleazy on + ## the part of webget, but the alternative is to have flags, and + ## having them part of the URL like with FTP, etc., seems a bit + ## cleaner to me in the context of how webget is used). + ## + ## So, if we're doing this slezy thing, we need to construct + ## the new URL from the compnents we have now (leaving out password + ## and user), decode the proxy URL, then return the info for + ## that host, a "filename" of the entire URL we really want, and + ## the user/password from the original URL. + ## + ## For all other things, we can just take the original URL, + ## ensure it has a protocol on it, and pass it as the "filename" + ## we want to the proxy host. The difference between reconstructing + ## the URL (as for HTTP Authentication) and just ensuring the + ## protocol is there is, except for the user/password stuff, + ## nothing. In theory, at least. + ## + if ($protocol eq 'http' && (defined($password) || defined($user))) + { + $path = "http://$address$path"; + $old_pass = $password; + $old_user = $user; + } else { + ## Re-get original URL and ensure protocol// actually there. + ## This will become our new path. + ($path = $_) =~ s,^($protocol:)?/*,$protocol://,i; + } + + ## note what the target will be + $target = ($port==$default_port{$protocol})?$address:"$address:$port"; + + ## get proxy info, discarding + ($protocol, $address, $port, $dummy, $dummy, $user, $password) + = &grok_URL($proxy, 1); + $password = $old_pass if defined $old_pass; + $user = $old_user if defined $old_user; + } + ($protocol, $address, $port, $path, $target, $user, $password); +} + + + +## +## &no_proxy($protocol, $host) +## +## Returns true if the specified host is identified in the no_proxy +## environmental variable, or identify the proxy server itself. +## +sub no_proxy +{ + local($protocol, $targethost) = @_; + local(@dests, $dest, $host, @hosts, $aliases); + local($proxy) = $ENV{$protocol."_proxy"}; + return 0 if !defined $proxy; + $targethost =~ tr/A-Z/a-z/; ## ensure all lowercase; + + @dests = ($proxy); + push(@dests,split(/\s*,\s*/,$ENV{'no_proxy'})) if defined $ENV{'no_proxy'}; + + foreach $dest (@dests) + { + ## just get the hostname + $host = (&grok_URL($dest, 1), 'http')[1]; + + if (!defined $host) { + warn "can't grok [$dest] from no_proxy env.var.\n"; + next; + } + @hosts = ($host); ## throw in original name just to make sure + ($host, $aliases) = (gethostbyname($host))[0, 1]; + + if (defined $aliases) { + push(@hosts, ($host, split(/\s+/, $aliases))); + } else { + push(@hosts, $host); + } + foreach $host (@hosts) { + next if !defined $host; + return 1 if "\L$host" eq $targethost; + } + } + return 0; +} + +sub ensure_proper_network_library +{ + require 'network.pl' if !defined $network'version; + warn "WARNING:\n". __FILE__ . + qq/ needs a newer version of "network.pl"\n/ if + !defined($network'version) || $network'version < "950311.5"; +} + + + +## +##> +############################################################################## +## open_http_connection(*FILEHANDLE, HOST, PORT, PATH, TARGET, OPTIONS...) +## +## Opens an HTTP connection to HOST:PORT and requests PATH. +## TARGET is used only for informational messages to the user. +## +## If PORT and PATH are undefined, HOST is taken as an http URL and TARGET +## is filled in as needed. +## +## Otherwise, it's the same as open_http_url (including return value, etc.). +##< +## +sub open_http_connection +{ + local(*HTTP, $host, $port, $path, $target, @options) = @_; + local($post_text, @error, %seen); + local(%info); + + &ensure_proper_network_library; + + ## options allowed: + local($post, $retry, $authorization, $nofollow, $noproxy, + $head, $debug, $ifmodifiedsince, $quiet, ) = (0) x 10; + ## parse options: + foreach $opt (@options) + { + next unless defined($opt) && $opt ne ''; + local($var, $val); + if ($opt =~ m/^(\w+)=(.*)/) { + ($var, $val) = ($1, $2); + } else { + $var = $opt; + $val = 1; + } + $var =~ tr/A-Z/a-z/; ## ensure variable is lowercase. + local(@error); + + eval "if (defined \$$var) { \$$var = \$val; } else { \@error = + ('error', 'bad open_http_connection option [$opt]'); }"; + return ('error', "open_http_connection eval: $@") if $@; + return @error if defined @error; + } + $quiet = 0 if $debug; ## debug overrides quiet + + local($protocol, $error, $code, $URL, %info, $tmp, $aite); + + ## + ## if both PORT and PATH are undefined, treat HOST as a URL. + ## + unless (defined($port) && defined($path)) + { + ($protocol,$host,$port,$path,$target)=&grok_URL($host,$noproxy,'http'); + if ($protocol ne "http") { + return ('error',"open_http_connection doesn't grok [$protocol]"); + } + unless (defined($host)) { + return ('error', "can't grok [$URL]"); + } + } + + return ('error', "no port in URL [$URL]") unless defined $port; + return ('error', "no path in URL [$URL]") unless defined $path; + + RETRY: while(1) + { + ## we'll want $URL around for error messages and such. + if ($port == $default_port{'http'}) { + $URL = "http://$host"; + } else { + $URL = "http://$host:$default_port{'http'}"; + } + $URL .= ord($path) eq ord('/') ? $path : "/$path"; + + $aite = defined($target) ? "$target via $host" : $host; + + &message($debug, "connecting to $aite ...") unless $quiet; + + ## + ## note some info that might be of use to the caller. + ## + local(%preinfo) = ( + 'PROTOCOL', 'http', + 'HOST', $host, + 'PORT', $port, + 'PATH', $path, + ); + if (defined $target) { + $preinfo{'TARGET'} = $target; + } elsif ($default_port{'http'} == $port) { + $preinfo{'TARGET'} = $host; + } else { + $preinfo{'TARGET'} = "$host:$port"; + } + + ## connect to the site + $error = &network'connect_to(*HTTP, $host, $port); + if (defined $error) { + return('error', "can't connect to $aite: $error", %preinfo); + } + + ## If we're asked to POST and it looks like a POST, note post text. + if ($post && $path =~ m/\?/) { + $post_text = $'; ## everything after the '?' + $path = $`; ## everything before the '?' + } + + ## send the POST or GET request + $tmp = $head ? 'HEAD' : (defined $post_text ? 'POST' : 'GET'); + + &message($debug, "sending request to $aite ...") if !$quiet; + print HTTP $tmp, " $path HTTP/1.0\n"; + + ## send the If-Modified-Since field if needed. + if ($ifmodifiedsince) { + print HTTP "If-Modified-Since: $ifmodifiedsince\n"; + } + + ## oh, let's sputter a few platitudes..... + print HTTP "Accept: */*\n"; + print HTTP "User-Agent: $useragent\n" if defined $useragent; + + ## If doing Authorization, do so now. + if ($authorization) { + print HTTP "Authorization: Basic ", + &htuu_encode($authorization), "\n"; + } + + ## If it's a post, send it. + if (defined $post_text) + { + print HTTP "Content-type: application/x-www-form-urlencoded\n"; + print HTTP "Content-length: ", length $post_text, "\n\n"; + print HTTP $post_text, "\n"; + } + print HTTP "\n"; + &message($debug, "waiting for data from $aite ...") unless $quiet; + + ## we can now read the response (header, then body) via HTTP. + binmode(HTTP); ## just in case. + + ($code, %info) = &read_http_header(*HTTP); + &message(1, "header returns code $code ($info{'TYPE'})") if $debug; + + ## fill in info from %preinfo + local($val, $key); + while (($val, $key) = each %preinfo) { + $info{$val} = $key; + } + + if ($code == 0) + { + return('error',"empty response for $URL") + if $info{'TYPE'} eq 'empty'; + return('error', "non-HTTP response for $URL", %info) + if $info{'TYPE'} eq 'unknown'; + return('error', "unknown zero-code for $URL", %info); + } + + if ($code == 302) ## 302 is magic for "Found" + { + if (!defined $info{'location'}) { + return('error', "No location info for Found URL $URL", %info); + } + local($newURL) = $info{'location'}; + + ## Remove :80 from hostname, if there. Looks ugly. + $newURL =~ s,^(http:/+[^/:]+):80/,$1/,i; + $info{"NewURL"} = $newURL; + + ## if we're not following links or if it's not to HTTP, return. + return('follow', $newURL, %info) if + $nofollow || $newURL!~m/^http:/i; + + ## note that we've seen this current URL. + $seen{$host, $port, $path} = 1; + + &message(1, qq/[note: now moved to "$newURL"]/) unless $quiet; + + + ## get the new one and return an error if it's been seen. + ($protocol, $host, $port, $path, $target) = + &www'grok_URL($newURL, $noproxy); + &message(1, "[$protocol][$host][$port][$path]") if $debug; + + if (defined $seen{$host, $port, $path}) + { + return('error', "circular reference among:\n ". + join("\n ", sort grep(/^http/i, keys %seen)), %seen); + } + next RETRY; + } + elsif ($code == 500) ## 500 is magic for "internal error" + { + ## + ## A proxy will often return this with text saying "can't find + ## host" when in reality it's just because the nslookup returned + ## null at the time. Such a thing should be retied again after a + ## few seconds. + ## + if ($retry) + { + local($_) = $info{'BODY'} = join('', <HTTP>); + if (/Can't locate remote host:\s*(\S+)/i) { + local($times) = ($retry == 1) ? + "once more" : "up to $retry more times"; + &message(0, "can't locate $1, will try $times ...") + unless $quiet; + sleep(5); + $retry--; + next RETRY; + } + } + } + + if ($code != 200) ## 200 is magic for "OK"; + { + ## I'll deal with these as I see them..... + &clear_message; + if ($info{'TYPE'} eq '') + { + if (defined $http_return_code{$code}) { + $info{'TYPE'} = $http_return_code{$code}; + } else { + $info{'TYPE'} = "(unknown status code $code)"; + } + } + return ('status', $info{'TYPE'}, %info); + } + + &clear_message; + return ('ok', 'ok', %info); + } +} + + +## +## Hyper Text UUencode. Somewhat different from regular uuencode. +## +## Logic taken from Mosaic for X code by Mark Riordan and Ari Luotonen. +## +sub htuu_encode +{ + local(@in) = unpack("C*", $_[0]); + local(@out); + + push(@in, 0, 0); ## in case we need to round off an odd byte or two + while (@in >= 3) { + ## + ## From the next three input bytes, + ## construct four encoded output bytes. + ## + push(@out, $in[0] >> 2); + push(@out, (($in[0] << 4) & 060) | (($in[1] >> 4) & 017)); + push(@out, (($in[1] << 2) & 074) | (($in[2] >> 6) & 003)); + push(@out, $in[2] & 077); + splice(@in, 0, 3); ## remove these three + } + + ## + ## @out elements are now indices to the string below. Convert to + ## the appropriate actual text. + ## + foreach $new (@out) { + $new = substr( + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", + $new, 1); + } + + if (@in == 2) { + ## the two left over are the two extra nulls, so we encoded the proper + ## amount as-is. + } elsif (@in == 1) { + ## We encoded one extra null too many. Undo it. + $out[$#out] = '='; + } else { + ## We must have encoded two nulls... Undo both. + $out[$#out ] = '='; + $out[$#out -1] = '='; + } + + join('', @out); +} + +## +## This message stuff really shouldn't be here, but in some seperate library. +## Sorry. +## +## Called as &message(SAVE, TEXT ....), it shoves the text to the screen. +## If SAVE is true, bumps the text out as a printed line. Otherwise, +## will shove out without a newline so that the next message overwrites it, +## or it is clearded via &clear_message(). +## +sub message +{ + local($nl) = shift; + die "oops $nl." unless $nl =~ m/^\d+$/; + local($text) = join('', @_); + local($NL) = $nl ? "\n" : "\r"; + $thislength = length($text); + if ($thislength >= $last_message_length) { + print STDERR $text, $NL; + } else { + print STDERR $text, ' 'x ($last_message_length-$thislength), $NL; + } + $last_message_length = $nl ? 0 : $thislength; +} + +sub clear_message +{ + if ($last_message_length) { + print STDERR ' ' x $last_message_length, "\r"; + $last_message_length = 0; + } +} + +1; +__END__ diff --git a/gnu/usr.bin/perl/win32/config.bc b/gnu/usr.bin/perl/win32/config.bc new file mode 100644 index 00000000000..ad76309e5d9 --- /dev/null +++ b/gnu/usr.bin/perl/win32/config.bc @@ -0,0 +1,498 @@ +# +## This file was hand coded and a lot of information is invalid +# +## Configured by: ~cf_email~ +## Target system: WIN32 +# + +archlibexp='~INST_TOP~\lib' +archname='MSWin32' +cc='bcc32' +ccflags='-DWIN32' +cppflags='-DWIN32' +dlsrc='dl_win32.xs' +dynamic_ext='Fcntl IO Opcode SDBM_File Socket' +extensions='Fcntl IO Opcode SDBM_File Socket' +installarchlib='~INST_TOP~\lib' +installprivlib='~INST_TOP~\lib' +libpth='' +libs='' +osname='MSWin32' +osvers='4.0' +prefix='~INST_DRV~' +privlibexp='~INST_TOP~\lib' +sharpbang='#!' +shsharp='true' +sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM USR1 USR2 CHLD PWR WINCH URG IO STOP TSTP CONT TTIN TTOU VTALRM PROF XCPU XFSZ WAITING LWP FREEZE THAW RTMIN NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 RTMAX IOT CLD POLL' +so='dll' +startsh='#!/bin/sh' +static_ext=' ' +Author='' +CONFIG='true' +Date='$Date' +Header='' +Id='$Id' +Locker='' +Log='$Log' +Mcc='Mcc' +PATCHLEVEL='~PATCHLEVEL~' +POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"' +RCSfile='$RCSfile' +Revision='$Revision' +SUBVERSION='~SUBVERSION~' +Source='' +State='' +afs='false' +alignbytes='8' +aphostname='' +ar='tlib /P128' +archlib='~INST_TOP~\lib' +archobjs='' +awk='awk' +baserev='5.0' +bash='' +bin='~INST_TOP~\bin' +binexp='~INST_TOP~\bin' +bison='' +byacc='byacc' +byteorder='1234' +c='' +castflags='0' +cat='type' +cccdlflags='' +ccdlflags=' ' +cf_by='garyng' +cf_email='71564.1743@compuserve.com' +cf_time='Thu Apr 11 06:20:49 PDT 1996' +chgrp='' +chmod='' +chown='' +clocktype='clock_t' +comm='' +compress='' +contains='grep' +cp='copy' +cpio='' +cpp='cpp32' +cpp_stuff='42' +cpplast='' +cppminus='' +cpprun='' +cppstdin='' +cryptlib='' +csh='undef' +d_Gconvert='gcvt((x),(n),(b))' +d_access='define' +d_alarm='undef' +d_archlib='define' +d_attribut='undef' +d_bcmp='undef' +d_bcopy='undef' +d_bincompat3='undef' +d_bsd='define' +d_bsdgetpgrp='undef' +d_bsdpgrp='undef' +d_bsdsetpgrp='undef' +d_bzero='undef' +d_casti32='define' +d_castneg='define' +d_charvspr='undef' +d_chown='undef' +d_chroot='undef' +d_chsize='define' +d_closedir='define' +d_const='define' +d_crypt='undef' +d_csh='undef' +d_cuserid='undef' +d_dbl_dig='define' +d_difftime='define' +d_dirnamlen='define' +d_dlerror='define' +d_dlopen='define' +d_dlsymun='undef' +d_dosuid='undef' +d_dup2='define' +d_eofnblk='define' +d_eunice='undef' +d_fchmod='undef' +d_fchown='undef' +d_fcntl='undef' +d_fd_macros='define' +d_fd_set='define' +d_fds_bits='define' +d_fgetpos='define' +d_flexfnam='define' +d_flock='define' +d_fork='undef' +d_fpathconf='undef' +d_fsetpos='define' +d_getgrps='undef' +d_setgrps='undef' +d_gethent='undef' +d_gethname='undef' +d_getlogin='undef' +d_getpgrp2='undef' +d_getpgrp='undef' +d_getpgid='undef' +d_getppid='undef' +d_getprior='undef' +d_gettimeod='undef' +d_htonl='define' +d_index='undef' +d_inetaton='undef' +d_isascii='define' +d_killpg='undef' +d_link='undef' +d_locconv='define' +d_lockf='undef' +d_lstat='undef' +d_mblen='define' +d_mbstowcs='define' +d_mbtowc='define' +d_memcmp='define' +d_memcpy='define' +d_memmove='define' +d_memset='define' +d_mkdir='define' +d_mkfifo='undef' +d_mktime='define' +d_msg='undef' +d_msgctl='define' +d_msgget='define' +d_msgrcv='define' +d_msgsnd='define' +d_mymalloc='undef' +d_nice='undef' +d_oldarchlib='undef' +d_oldsock='undef' +d_open3='undef' +d_pathconf='undef' +d_pause='define' +d_phostname='undef' +d_pipe='define' +d_poll='undef' +d_portable='define' +d_pwage='undef' +d_pwchange='undef' +d_pwclass='undef' +d_pwcomment='undef' +d_pwexpire='undef' +d_pwquota='undef' +d_readdir='define' +d_readlink='undef' +d_rename='define' +d_rewinddir='define' +d_rmdir='define' +d_safebcpy='undef' +d_safemcpy='undef' +d_sanemcmp='define' +d_seekdir='define' +d_select='define' +d_sem='undef' +d_semctl='define' +d_semget='define' +d_semop='define' +d_setegid='undef' +d_seteuid='undef' +d_setlinebuf='undef' +d_setlocale='define' +d_setpgid='undef' +d_setpgrp2='undef' +d_setpgrp='undef' +d_setprior='undef' +d_setregid='undef' +d_setresgid='undef' +d_setresuid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' +d_setsid='undef' +d_sfio='undef' +d_shm='undef' +d_shmat='undef' +d_shmatprototype='undef' +d_shmctl='define' +d_shmdt='define' +d_shmget='define' +d_shrplib='undef' +d_sigaction='undef' +d_sigintrp='' +d_sigsetjmp='undef' +d_sigvec='define' +d_sigvectr='undef' +d_socket='define' +d_sockpair='undef' +d_statblks='undef' +d_stdio_cnt_lval='define' +d_stdio_ptr_lval='define' +d_stdiobase='define' +d_stdstdio='define' +d_strchr='define' +d_strcoll='define' +d_strctcpy='define' +d_strerrm='strerror(e)' +d_strerror='define' +d_strtod='define' +d_strtol='define' +d_strtoul='define' +d_strxfrm='define' +d_suidsafe='undef' +d_symlink='undef' +d_syscall='undef' +d_sysconf='undef' +d_sysernlst='' +d_syserrlst='define' +d_system='define' +d_tcgetpgrp='undef' +d_tcsetpgrp='undef' +d_telldir='define' +d_time='define' +d_times='define' +d_truncate='undef' +d_tzname='define' +d_umask='define' +d_uname='undef' +d_vfork='undef' +d_void_closedir='undef' +d_voidsig='define' +d_voidtty='' +d_volatile='define' +d_vprintf='define' +d_wait4='undef' +d_waitpid='undef' +d_wcstombs='define' +d_wctomb='define' +d_xenix='undef' +date='date' +db_hashtype='int' +db_prefixtype='int' +defvoidused='15' +direntrytype='struct direct' +dlext='dll' +eagain='EAGAIN' +echo='echo' +egrep='egrep' +emacs='' +eunicefix=':' +exe_ext='.exe' +expr='expr' +find='find' +firstmakefile='makefile' +flex='' +fpostype='fpos_t' +freetype='void' +full_csh='' +full_sed='' +gcc='' +gccversion='' +gidtype='gid_t' +glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib ' +grep='grep' +groupcat='' +groupstype='gid_t' +h_fcntl='false' +h_sysfile='true' +hint='recommended' +hostcat='ypcat hosts' +huge='' +i_bsdioctl='' +i_db='undef' +i_dbm='undef' +i_dirent='define' +i_dld='undef' +i_dlfcn='define' +i_fcntl='define' +i_float='define' +i_gdbm='define' +i_grp='define' +i_limits='define' +i_locale='define' +i_malloc='define' +i_math='define' +i_memory='undef' +i_ndbm='undef' +i_neterrno='undef' +i_niin='undef' +i_pwd='undef' +i_rpcsvcdbm='define' +i_sfio='undef' +i_sgtty='undef' +i_stdarg='define' +i_stddef='define' +i_stdlib='define' +i_string='define' +i_sysdir='undef' +i_sysfile='undef' +i_sysfilio='define' +i_sysin='undef' +i_sysioctl='undef' +i_sysndir='undef' +i_sysparam='undef' +i_sysresrc='undef' +i_sysselct='undef' +i_syssockio='' +i_sysstat='define' +i_systime='undef' +i_systimek='undef' +i_systimes='undef' +i_systypes='define' +i_sysun='undef' +i_syswait='undef' +i_termio='undef' +i_termios='undef' +i_time='define' +i_unistd='undef' +i_utime='define' +i_values='undef' +i_varargs='undef' +i_varhdr='varargs.h' +i_vfork='undef' +incpath='' +inews='' +installbin='~INST_TOP~\bin' +installman1dir='~INST_TOP~\man\man1' +installman3dir='~INST_TOP~\man\man3' +installscript='~INST_TOP~\bin' +installsitearch='~INST_TOP~\lib\site' +installsitelib='~INST_TOP~\lib\site' +intsize='4' +known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket' +ksh='' +large='' +ld='tlink32' +lddlflags='-Tpd' +ldflags='' +less='less' +lib_ext='.lib' +libc='cw32mti.lib' +libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' +line='line' +lint='' +lkflags='' +ln='' +lns='copy' +locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' +loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' +longsize='4' +lp='' +lpr='' +ls='dir' +lseektype='off_t' +mail='' +mailx='' +make='dmake' +mallocobj='malloc.o' +mallocsrc='malloc.c' +malloctype='void *' +man1dir='~INST_TOP~\man\man1' +man1direxp='~INST_TOP~\man\man1' +man1ext='1' +man3dir='~INST_TOP~\man\man3' +man3direxp='~INST_TOP~\man\man3' +man3ext='3' +medium='' +mips='' +mips_type='' +mkdir='mkdir' +models='none' +modetype='mode_t' +more='more /e' +mv='' +myarchname='MSWin32' +mydomain='' +myhostname='' +myuname='' +n='-n' +nm_opt='' +nm_so_opt='' +nroff='' +o_nonblock='O_NONBLOCK' +obj_ext='.obj' +oldarchlib='' +oldarchlibexp='' +optimize='-O' +orderlib='false' +package='perl5' +pager='more /e' +passcat='' +patchlevel='2' +path_sep=';' +perl='perl' +perladmin='' +perlpath='~INST_TOP~\bin\perl.exe' +pg='' +phostname='hostname' +plibpth='' +pmake='' +pr='' +prefixexp='~INST_DRV~' +privlib='~INST_TOP~\lib' +prototype='define' +randbits='15' +ranlib='' +rd_nodata='-1' +rm='del' +rmail='' +runnm='true' +scriptdir='~INST_TOP~\bin' +scriptdirexp='~INST_TOP~\bin' +sed='sed' +selecttype='int *' +sendmail='blat' +sh='cmd /x /c' +shar='' +shmattype='void *' +shortsize='2' +shrpdir='none' +sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22' +signal_t='void' +sitearch='~INST_TOP~\lib\site' +sitearchexp='~INST_TOP~\lib\site' +sitelib='~INST_TOP~\lib\site' +sitelibexp='~INST_TOP~\lib\site' +sizetype='size_t' +sleep='' +smail='' +small='' +sockethdr='' +socketlib='' +sort='sort' +spackage='Perl5' +spitshell='' +split='' +ssizetype='int' +startperl='#perl' +stdchar='unsigned char' +stdio_base='((fp)->buffer)' +stdio_bufsiz='((fp)->level + (fp)->curp - (fp)->buffer)' +stdio_cnt='((fp)->level)' +stdio_ptr='((fp)->curp)' +strings='/usr/include/string.h' +submit='' +sysman='/usr/man/man1' +tail='' +tar='' +tbl='' +test='' +timeincl='/usr/include/sys/time.h ' +timetype='time_t' +touch='touch' +tr='' +troff='' +uidtype='uid_t' +uname='uname' +uniq='uniq' +usedl='define' +usemymalloc='n' +usenm='false' +useperlio='undef' +useposix='true' +usesafe='true' +usevfork='false' +usrinc='/usr/include' +uuname='' +vi='' +voidflags='15' +xlibpth='/usr/lib/386 /lib/386' +zcat='' diff --git a/gnu/usr.bin/perl/win32/config.vc b/gnu/usr.bin/perl/win32/config.vc new file mode 100644 index 00000000000..7cc91dabd3b --- /dev/null +++ b/gnu/usr.bin/perl/win32/config.vc @@ -0,0 +1,498 @@ +# +## This file was hand coded and a lot of information is invalid +# +## Configured by: ~cf_email~ +## Target system: WIN32 +# + +archlibexp='~INST_TOP~\lib' +archname='MSWin32' +cc='cl' +ccflags='-MD -DWIN32' +cppflags='-DWIN32' +dlsrc='dl_win32.xs' +dynamic_ext='Fcntl IO Opcode SDBM_File Socket' +extensions='Fcntl IO Opcode SDBM_File Socket' +installarchlib='~INST_TOP~\lib' +installprivlib='~INST_TOP~\lib' +libpth='' +libs='' +osname='MSWin32' +osvers='4.0' +prefix='~INST_DRV~' +privlibexp='~INST_TOP~\lib' +sharpbang='#!' +shsharp='true' +sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM USR1 USR2 CHLD PWR WINCH URG IO STOP TSTP CONT TTIN TTOU VTALRM PROF XCPU XFSZ WAITING LWP FREEZE THAW RTMIN NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 RTMAX IOT CLD POLL' +so='dll' +startsh='#!/bin/sh' +static_ext=' ' +Author='' +CONFIG='true' +Date='$Date' +Header='' +Id='$Id' +Locker='' +Log='$Log' +Mcc='Mcc' +PATCHLEVEL='~PATCHLEVEL~' +POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"' +RCSfile='$RCSfile' +Revision='$Revision' +SUBVERSION='~SUBVERSION~' +Source='' +State='' +afs='false' +alignbytes='8' +aphostname='' +ar='lib' +archlib='~INST_TOP~\lib' +archobjs='' +awk='awk' +baserev='5.0' +bash='' +bin='~INST_TOP~\bin' +binexp='~INST_TOP~\bin' +bison='' +byacc='byacc' +byteorder='1234' +c='' +castflags='0' +cat='type' +cccdlflags='' +ccdlflags=' ' +cf_by='garyng' +cf_email='71564.1743@compuserve.com' +cf_time='Thu Apr 11 06:20:49 PDT 1996' +chgrp='' +chmod='' +chown='' +clocktype='clock_t' +comm='' +compress='' +contains='grep' +cp='copy' +cpio='' +cpp='cpp' +cpp_stuff='42' +cpplast='' +cppminus='' +cpprun='cl -E' +cppstdin='cl -E' +cryptlib='' +csh='undef' +d_Gconvert='sprintf((b),"%.*g",(n),(x))' +d_access='define' +d_alarm='undef' +d_archlib='define' +d_attribut='undef' +d_bcmp='undef' +d_bcopy='undef' +d_bincompat3='undef' +d_bsd='define' +d_bsdgetpgrp='undef' +d_bsdpgrp='undef' +d_bsdsetpgrp='undef' +d_bzero='undef' +d_casti32='define' +d_castneg='define' +d_charvspr='undef' +d_chown='undef' +d_chroot='undef' +d_chsize='define' +d_closedir='define' +d_const='define' +d_crypt='undef' +d_csh='undef' +d_cuserid='undef' +d_dbl_dig='define' +d_difftime='define' +d_dirnamlen='define' +d_dlerror='define' +d_dlopen='define' +d_dlsymun='undef' +d_dosuid='undef' +d_dup2='define' +d_eofnblk='define' +d_eunice='undef' +d_fchmod='undef' +d_fchown='undef' +d_fcntl='undef' +d_fd_macros='define' +d_fd_set='define' +d_fds_bits='define' +d_fgetpos='define' +d_flexfnam='define' +d_flock='define' +d_fork='undef' +d_fpathconf='undef' +d_fsetpos='define' +d_getgrps='undef' +d_setgrps='undef' +d_gethent='undef' +d_gethname='undef' +d_getlogin='undef' +d_getpgrp2='undef' +d_getpgrp='undef' +d_getpgid='undef' +d_getppid='undef' +d_getprior='undef' +d_gettimeod='undef' +d_htonl='define' +d_index='undef' +d_inetaton='undef' +d_isascii='define' +d_killpg='undef' +d_link='undef' +d_locconv='define' +d_lockf='undef' +d_lstat='undef' +d_mblen='define' +d_mbstowcs='define' +d_mbtowc='define' +d_memcmp='define' +d_memcpy='define' +d_memmove='define' +d_memset='define' +d_mkdir='define' +d_mkfifo='undef' +d_mktime='define' +d_msg='undef' +d_msgctl='define' +d_msgget='define' +d_msgrcv='define' +d_msgsnd='define' +d_mymalloc='undef' +d_nice='undef' +d_oldarchlib='undef' +d_oldsock='undef' +d_open3='undef' +d_pathconf='undef' +d_pause='define' +d_phostname='undef' +d_pipe='define' +d_poll='undef' +d_portable='define' +d_pwage='undef' +d_pwchange='undef' +d_pwclass='undef' +d_pwcomment='undef' +d_pwexpire='undef' +d_pwquota='undef' +d_readdir='define' +d_readlink='undef' +d_rename='define' +d_rewinddir='define' +d_rmdir='define' +d_safebcpy='undef' +d_safemcpy='undef' +d_sanemcmp='define' +d_seekdir='define' +d_select='define' +d_sem='undef' +d_semctl='define' +d_semget='define' +d_semop='define' +d_setegid='undef' +d_seteuid='undef' +d_setlinebuf='undef' +d_setlocale='define' +d_setpgid='undef' +d_setpgrp2='undef' +d_setpgrp='undef' +d_setprior='undef' +d_setregid='undef' +d_setresgid='undef' +d_setresuid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' +d_setsid='undef' +d_sfio='undef' +d_shm='undef' +d_shmat='undef' +d_shmatprototype='undef' +d_shmctl='define' +d_shmdt='define' +d_shmget='define' +d_shrplib='undef' +d_sigaction='undef' +d_sigintrp='' +d_sigsetjmp='undef' +d_sigvec='define' +d_sigvectr='undef' +d_socket='define' +d_sockpair='undef' +d_statblks='undef' +d_stdio_cnt_lval='define' +d_stdio_ptr_lval='define' +d_stdiobase='define' +d_stdstdio='define' +d_strchr='define' +d_strcoll='define' +d_strctcpy='define' +d_strerrm='strerror(e)' +d_strerror='define' +d_strtod='define' +d_strtol='define' +d_strtoul='define' +d_strxfrm='define' +d_suidsafe='undef' +d_symlink='undef' +d_syscall='undef' +d_sysconf='undef' +d_sysernlst='' +d_syserrlst='define' +d_system='define' +d_tcgetpgrp='undef' +d_tcsetpgrp='undef' +d_telldir='define' +d_time='define' +d_times='define' +d_truncate='undef' +d_tzname='define' +d_umask='define' +d_uname='undef' +d_vfork='undef' +d_void_closedir='undef' +d_voidsig='define' +d_voidtty='' +d_volatile='define' +d_vprintf='define' +d_wait4='undef' +d_waitpid='undef' +d_wcstombs='define' +d_wctomb='define' +d_xenix='undef' +date='date' +db_hashtype='int' +db_prefixtype='int' +defvoidused='15' +direntrytype='struct direct' +dlext='dll' +eagain='EAGAIN' +echo='echo' +egrep='egrep' +emacs='' +eunicefix=':' +exe_ext='.exe' +expr='expr' +find='find' +firstmakefile='makefile' +flex='' +fpostype='fpos_t' +freetype='void' +full_csh='' +full_sed='' +gcc='' +gccversion='' +gidtype='gid_t' +glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib ' +grep='grep' +groupcat='' +groupstype='gid_t' +h_fcntl='false' +h_sysfile='true' +hint='recommended' +hostcat='ypcat hosts' +huge='' +i_bsdioctl='' +i_db='undef' +i_dbm='undef' +i_dirent='define' +i_dld='undef' +i_dlfcn='define' +i_fcntl='define' +i_float='define' +i_gdbm='define' +i_grp='define' +i_limits='define' +i_locale='define' +i_malloc='define' +i_math='define' +i_memory='undef' +i_ndbm='undef' +i_neterrno='undef' +i_niin='undef' +i_pwd='undef' +i_rpcsvcdbm='define' +i_sfio='undef' +i_sgtty='undef' +i_stdarg='define' +i_stddef='define' +i_stdlib='define' +i_string='define' +i_sysdir='undef' +i_sysfile='undef' +i_sysfilio='define' +i_sysin='undef' +i_sysioctl='undef' +i_sysndir='undef' +i_sysparam='undef' +i_sysresrc='undef' +i_sysselct='undef' +i_syssockio='' +i_sysstat='define' +i_systime='undef' +i_systimek='undef' +i_systimes='undef' +i_systypes='define' +i_sysun='undef' +i_syswait='undef' +i_termio='undef' +i_termios='undef' +i_time='define' +i_unistd='undef' +i_utime='define' +i_values='undef' +i_varargs='undef' +i_varhdr='varargs.h' +i_vfork='undef' +incpath='' +inews='' +installbin='~INST_TOP~\bin' +installman1dir='~INST_TOP~\man\man1' +installman3dir='~INST_TOP~\man\man3' +installscript='~INST_TOP~\bin' +installsitearch='~INST_TOP~\lib\site' +installsitelib='~INST_TOP~\lib\site' +intsize='4' +known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket' +ksh='' +large='' +ld='link' +lddlflags='-dll' +ldflags='-nologo -subsystem:windows' +less='less' +lib_ext='.lib' +libc='msvcrt.lib' +libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' +line='line' +lint='' +lkflags='' +ln='' +lns='copy' +locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' +loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' +longsize='4' +lp='' +lpr='' +ls='dir' +lseektype='off_t' +mail='' +mailx='' +make='nmake' +mallocobj='malloc.o' +mallocsrc='malloc.c' +malloctype='void *' +man1dir='~INST_TOP~\man\man1' +man1direxp='~INST_TOP~\man\man1' +man1ext='1' +man3dir='~INST_TOP~\man\man3' +man3direxp='~INST_TOP~\man\man3' +man3ext='3' +medium='' +mips='' +mips_type='' +mkdir='mkdir' +models='none' +modetype='mode_t' +more='more /e' +mv='' +myarchname='MSWin32' +mydomain='' +myhostname='' +myuname='' +n='-n' +nm_opt='' +nm_so_opt='' +nroff='' +o_nonblock='O_NONBLOCK' +obj_ext='.obj' +oldarchlib='' +oldarchlibexp='' +optimize='-O' +orderlib='false' +package='perl5' +pager='more /e' +passcat='' +patchlevel='2' +path_sep=';' +perl='perl' +perladmin='' +perlpath='~INST_TOP~\bin\perl.exe' +pg='' +phostname='hostname' +plibpth='' +pmake='' +pr='' +prefixexp='~INST_DRV~' +privlib='~INST_TOP~\lib' +prototype='define' +randbits='15' +ranlib='' +rd_nodata='-1' +rm='del' +rmail='' +runnm='true' +scriptdir='~INST_TOP~\bin' +scriptdirexp='~INST_TOP~\bin' +sed='sed' +selecttype='int *' +sendmail='blat' +sh='cmd /x /c' +shar='' +shmattype='void *' +shortsize='2' +shrpdir='none' +sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22' +signal_t='void' +sitearch='~INST_TOP~\lib\site' +sitearchexp='~INST_TOP~\lib\site' +sitelib='~INST_TOP~\lib\site' +sitelibexp='~INST_TOP~\lib\site' +sizetype='size_t' +sleep='' +smail='' +small='' +sockethdr='' +socketlib='' +sort='sort' +spackage='Perl5' +spitshell='' +split='' +ssizetype='int' +startperl='#perl' +stdchar='unsigned char' +stdio_base='((fp)->_base)' +stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' +stdio_cnt='((fp)->_cnt)' +stdio_ptr='((fp)->_ptr)' +strings='/usr/include/string.h' +submit='' +sysman='/usr/man/man1' +tail='' +tar='' +tbl='' +test='' +timeincl='/usr/include/sys/time.h ' +timetype='time_t' +touch='touch' +tr='' +troff='' +uidtype='uid_t' +uname='uname' +uniq='uniq' +usedl='define' +usemymalloc='n' +usenm='false' +useperlio='undef' +useposix='true' +usesafe='true' +usevfork='false' +usrinc='/usr/include' +uuname='' +vi='' +voidflags='15' +xlibpth='/usr/lib/386 /lib/386' +zcat='' diff --git a/gnu/usr.bin/perl/win32/config_H.bc b/gnu/usr.bin/perl/win32/config_H.bc new file mode 100644 index 00000000000..61fb5a32412 --- /dev/null +++ b/gnu/usr.bin/perl/win32/config_H.bc @@ -0,0 +1,1802 @@ +/* + * This file was produced by running the config_h.SH script, which + * gets its values from config.sh, which is generally produced by + * running Configure. + * + * Feel free to modify any of this as the need arises. Note, however, + * that running config_h.SH again will wipe out any changes you've made. + * For a more permanent change edit config.sh and rerun config_h.SH. + * + * $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ + */ + +/* Configuration time: Thu Apr 11 06:20:49 PDT 1996 + * Configured by: garyng + * Target system: + */ + +#ifndef _config_h_ +#define _config_h_ + +/* MEM_ALIGNBYTES: + * This symbol contains the number of bytes required to align a + * double. Usual values are 2, 4 and 8. + * On NeXT starting with 3.2, you can build "Fat" Multiple Architecture + * Binaries (MAB) for targets with varying alignment. This only matters + * for perl, where the config.h can be generated and installed on one + * system, and used by a different architecture to build an extension. + * The default is eight, for safety. + */ +#ifndef NeXT +#define MEM_ALIGNBYTES 8 /**/ +#else /* NeXT */ +#ifdef __m68k__ +#define MEM_ALIGNBYTES 2 +#else +#ifdef __i386__ +#define MEM_ALIGNBYTES 4 +#else /* __hppa__, __sparc__ and default for unknown architectures */ +#define MEM_ALIGNBYTES 8 +#endif /* __i386__ */ +#endif /* __m68k__ */ +#endif /* NeXT */ + +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#ifdef _ALPHA_ +#define ARCHNAME "alpha-mswin32" /**/ +#else +#define ARCHNAME "x86-mswin32" /**/ +#endif + +/* BIN: + * This symbol holds the path of the bin directory where the package will + * be installed. Program must be prepared to deal with ~name substitution. + */ +/* BIN_EXP: + * This symbol is the filename expanded version of the BIN symbol, for + * programs that do not want to deal with that at run-time. + */ +#define BIN "c:\\perl\\bin" /**/ +#define BIN_EXP "c:\\perl\\bin" /**/ + +/* CAT2: + * This macro catenates 2 tokens together. + */ +/* STRINGIFY: + * This macro surrounds its token with double quotes. + */ +#if 42 == 1 +#define CAT2(a,b)a/**/b +#define CAT3(a,b,c)a/**/b/**/c +#define CAT4(a,b,c,d)a/**/b/**/c/**/d +#define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e +#define STRINGIFY(a)"a" + /* If you can get stringification with catify, tell me how! */ +#endif +#if 42 == 42 +#define CAT2(a,b)a ## b +#define CAT3(a,b,c)a ## b ## c +#define CAT4(a,b,c,d)a ## b ## c ## d +#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e +#define StGiFy(a)# a +#define STRINGIFY(a)StGiFy(a) +#define SCAT2(a,b)StGiFy(a) StGiFy(b) +#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) +#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) +#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) +#endif +#ifndef CAT2 +#include "Bletch: How does this C preprocessor catenate tokens?" +#endif + +/* CPPSTDIN: + * This symbol contains the first part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. Typical value of "cc -E" or "/lib/cpp", but it can also + * call a wrapper. See CPPRUN. + */ +/* CPPMINUS: + * This symbol contains the second part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. This symbol will have the value "-" if CPPSTDIN needs a minus + * to specify standard input, otherwise the value is "". + */ +#define CPPSTDIN "" +#define CPPMINUS "" + +/* HAS_ALARM: + * This symbol, if defined, indicates that the alarm routine is + * available. + */ +/*#define HAS_ALARM /**/ + +/* HASATTRIBUTE: + * This symbol indicates the C compiler can check for function attributes, + * such as printf formats. This is normally only supported by GNU cc. + */ +/*#define HASATTRIBUTE /**/ +#ifndef HASATTRIBUTE +#define __attribute__(_arg_) +#endif + +/* HAS_BCMP: + * This symbol is defined if the bcmp() routine is available to + * compare blocks of memory. + */ +/*#define HAS_BCMP /**/ + +/* HAS_BCOPY: + * This symbol is defined if the bcopy() routine is available to + * copy blocks of memory. + */ +/*#define HAS_BCOPY /**/ + +/* HAS_BZERO: + * This symbol is defined if the bzero() routine is available to + * set a memory block to 0. + */ +/*#define HAS_BZERO /**/ + +/* CASTI32: + * This symbol is defined if the C compiler can cast negative + * or large floating point numbers to 32-bit ints. + */ +#define CASTI32 /**/ + +/* CASTNEGFLOAT: + * This symbol is defined if the C compiler can cast negative + * numbers to unsigned longs, ints and shorts. + */ +/* CASTFLAGS: + * This symbol contains flags that say what difficulties the compiler + * has casting odd floating values to unsigned long: + * 0 = ok + * 1 = couldn't cast < 0 + * 2 = couldn't cast >= 0x80000000 + * 4 = couldn't cast in argument expression list + */ +#define CASTNEGFLOAT /**/ +#define CASTFLAGS 0 /**/ + +/* HAS_CHOWN: + * This symbol, if defined, indicates that the chown routine is + * available. + */ +/*#define HAS_CHOWN /**/ + +/* HAS_CHROOT: + * This symbol, if defined, indicates that the chroot routine is + * available. + */ +/*#define HAS_CHROOT /**/ + +/* HAS_CHSIZE: + * This symbol, if defined, indicates that the chsize routine is available + * to truncate files. You might need a -lx to get this routine. + */ +#define HAS_CHSIZE /**/ + +/* VOID_CLOSEDIR: + * This symbol, if defined, indicates that the closedir() routine + * does not return a value. + */ +/*#define VOID_CLOSEDIR /**/ + +/* HASCONST: + * This symbol, if defined, indicates that this C compiler knows about + * the const type. There is no need to actually test for that symbol + * within your programs. The mere use of the "const" keyword will + * trigger the necessary tests. + */ +#define HASCONST /**/ +#ifndef HASCONST +#define const +#endif + +/* HAS_CRYPT: + * This symbol, if defined, indicates that the crypt routine is available + * to encrypt passwords and the like. + */ +/*#define HAS_CRYPT /**/ + +/* HAS_CUSERID: + * This symbol, if defined, indicates that the cuserid routine is + * available to get character login names. + */ +/*#define HAS_CUSERID /**/ + +/* HAS_DBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol DBL_DIG, which is the number + * of significant digits in a double precision number. If this + * symbol is not defined, a guess of 15 is usually pretty good. + */ +#define HAS_DBL_DIG /**/ + +/* HAS_DIFFTIME: + * This symbol, if defined, indicates that the difftime routine is + * available. + */ +#define HAS_DIFFTIME /**/ + +/* HAS_DLERROR: + * This symbol, if defined, indicates that the dlerror routine is + * available to return a string describing the last error that + * occurred from a call to dlopen(), dlclose() or dlsym(). + */ +#define HAS_DLERROR /**/ + +/* HAS_DUP2: + * This symbol, if defined, indicates that the dup2 routine is + * available to duplicate file descriptors. + */ +#define HAS_DUP2 /**/ + +/* HAS_FCHMOD: + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +/*#define HAS_FCHMOD /**/ + +/* HAS_FCHOWN: + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +/*#define HAS_FCHOWN /**/ + +/* HAS_FCNTL: + * This symbol, if defined, indicates to the C program that + * the fcntl() function exists. + */ +/*#define HAS_FCNTL /**/ + +/* HAS_FGETPOS: + * This symbol, if defined, indicates that the fgetpos routine is + * available to get the file position indicator, similar to ftell(). + */ +#define HAS_FGETPOS /**/ + +/* FLEXFILENAMES: + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#define FLEXFILENAMES /**/ + +/* HAS_FLOCK: + * This symbol, if defined, indicates that the flock routine is + * available to do file locking. + */ +#define HAS_FLOCK /**/ + +/* HAS_FORK: + * This symbol, if defined, indicates that the fork routine is + * available. + */ +/*#define HAS_FORK /**/ + +/* HAS_FSETPOS: + * This symbol, if defined, indicates that the fsetpos routine is + * available to set the file position indicator, similar to fseek(). + */ +#define HAS_FSETPOS /**/ + +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). + * The type "Timeval" should be used to refer to "struct timeval". + */ +/*#define HAS_GETTIMEOFDAY /**/ +#ifdef HAS_GETTIMEOFDAY +#define Timeval struct timeval /* Structure used by gettimeofday() */ +#endif + +/* HAS_GETGROUPS: + * This symbol, if defined, indicates that the getgroups() routine is + * available to get the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +/* HAS_SETGROUPS: + * This symbol, if defined, indicates that the setgroups() routine is + * available to set the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +/*#define HAS_GETGROUPS /**/ +/*#define HAS_SETGROUPS /**/ + +/* HAS_GETHOSTENT: + * This symbol, if defined, indicates that the gethostent routine is + * available to lookup host names in some data base or other. + */ +/*#define HAS_GETHOSTENT /**/ + +/* HAS_UNAME: + * This symbol, if defined, indicates that the C program may use the + * uname() routine to derive the host name. See also HAS_GETHOSTNAME + * and PHOSTNAME. + */ +/*#define HAS_UNAME /**/ + +/* HAS_GETLOGIN: + * This symbol, if defined, indicates that the getlogin routine is + * available to get the login name. + */ +/*#define HAS_GETLOGIN /**/ + +/* HAS_GETPGRP2: + * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) + * routine is available to get the current process group. + */ +/*#define HAS_GETPGRP2 /**/ + +/* HAS_GETPPID: + * This symbol, if defined, indicates that the getppid routine is + * available to get the parent process ID. + */ +/*#define HAS_GETPPID /**/ + +/* HAS_GETPRIORITY: + * This symbol, if defined, indicates that the getpriority routine is + * available to get a process's priority. + */ +/*#define HAS_GETPRIORITY /**/ + +/* HAS_HTONL: + * This symbol, if defined, indicates that the htonl() routine (and + * friends htons() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_HTONS: + * This symbol, if defined, indicates that the htons() routine (and + * friends htonl() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHL: + * This symbol, if defined, indicates that the ntohl() routine (and + * friends htonl() htons() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHS: + * This symbol, if defined, indicates that the ntohs() routine (and + * friends htonl() htons() ntohl()) are available to do network + * order byte swapping. + */ +#define HAS_HTONL /**/ +#define HAS_HTONS /**/ +#define HAS_NTOHL /**/ +#define HAS_NTOHS /**/ + +/* HAS_ISASCII: + * This manifest constant lets the C program know that isascii + * is available. + */ +#define HAS_ISASCII /**/ + +/* HAS_KILLPG: + * This symbol, if defined, indicates that the killpg routine is available + * to kill process groups. If unavailable, you probably should use kill + * with a negative process number. + */ +/*#define HAS_KILLPG /**/ + +/* HAS_LINK: + * This symbol, if defined, indicates that the link routine is + * available to create hard links. + */ +/*#define HAS_LINK /**/ + +/* HAS_LOCALECONV: + * This symbol, if defined, indicates that the localeconv routine is + * available for numeric and monetary formatting conventions. + */ +#define HAS_LOCALECONV /**/ + +/* HAS_LOCKF: + * This symbol, if defined, indicates that the lockf routine is + * available to do file locking. + */ +/*#define HAS_LOCKF /**/ + +/* HAS_LSTAT: + * This symbol, if defined, indicates that the lstat routine is + * available to do file stats on symbolic links. + */ +/*#define HAS_LSTAT /**/ + +/* HAS_MBLEN: + * This symbol, if defined, indicates that the mblen routine is available + * to find the number of bytes in a multibye character. + */ +#define HAS_MBLEN /**/ + +/* HAS_MBSTOWCS: + * This symbol, if defined, indicates that the mbstowcs routine is + * available to covert a multibyte string into a wide character string. + */ +#define HAS_MBSTOWCS /**/ + +/* HAS_MBTOWC: + * This symbol, if defined, indicates that the mbtowc routine is available + * to covert a multibyte to a wide character. + */ +#define HAS_MBTOWC /**/ + +/* HAS_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. + */ +#define HAS_MEMCMP /**/ + +/* HAS_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy blocks of memory. + */ +#define HAS_MEMCPY /**/ + +/* HAS_MEMMOVE: + * This symbol, if defined, indicates that the memmove routine is available + * to copy potentially overlapping blocks of memory. This should be used + * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your + * own version. + */ +#define HAS_MEMMOVE /**/ + +/* HAS_MEMSET: + * This symbol, if defined, indicates that the memset routine is available + * to set blocks of memory. + */ +#define HAS_MEMSET /**/ + +/* HAS_MKDIR: + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#define HAS_MKDIR /**/ + +/* HAS_MKFIFO: + * This symbol, if defined, indicates that the mkfifo routine is + * available to create FIFOs. Otherwise, mknod should be able to + * do it for you. However, if mkfifo is there, mknod might require + * super-user privileges which mkfifo will not. + */ +/*#define HAS_MKFIFO /**/ + +/* HAS_MKTIME: + * This symbol, if defined, indicates that the mktime routine is + * available. + */ +#define HAS_MKTIME /**/ + +/* HAS_MSG: + * This symbol, if defined, indicates that the entire msg*(2) library is + * supported (IPC mechanism based on message queues). + */ +/*#define HAS_MSG /**/ + +/* HAS_NICE: + * This symbol, if defined, indicates that the nice routine is + * available. + */ +/*#define HAS_NICE /**/ + +/* HAS_OPEN3: + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. + */ +/*#define HAS_OPEN3 /**/ + +/* HAS_PATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given filename. + */ +/* HAS_FPATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given open file descriptor. + */ +/*#define HAS_PATHCONF /**/ +/*#define HAS_FPATHCONF /**/ + +/* HAS_PAUSE: + * This symbol, if defined, indicates that the pause routine is + * available to suspend a process until a signal is received. + */ +#define HAS_PAUSE /**/ + +/* HAS_PIPE: + * This symbol, if defined, indicates that the pipe routine is + * available to create an inter-process channel. + */ +#define HAS_PIPE /**/ + +/* HAS_POLL: + * This symbol, if defined, indicates that the poll routine is + * available to poll active file descriptors. + */ +/*#define HAS_POLL /**/ + +/* HAS_READDIR: + * This symbol, if defined, indicates that the readdir routine is + * available to read directory entries. You may have to include + * <dirent.h>. See I_DIRENT. + */ +#define HAS_READDIR /**/ + +/* HAS_SEEKDIR: + * This symbol, if defined, indicates that the seekdir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_SEEKDIR /**/ + +/* HAS_TELLDIR: + * This symbol, if defined, indicates that the telldir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_TELLDIR /**/ + +/* HAS_REWINDDIR: + * This symbol, if defined, indicates that the rewinddir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_REWINDDIR /**/ + +/* HAS_READLINK: + * This symbol, if defined, indicates that the readlink routine is + * available to read the value of a symbolic link. + */ +/*#define HAS_READLINK /**/ + +/* HAS_RENAME: + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#define HAS_RENAME /**/ + +/* HAS_RMDIR: + * This symbol, if defined, indicates that the rmdir routine is + * available to remove directories. Otherwise you should fork off a + * new process to exec /bin/rmdir. + */ +#define HAS_RMDIR /**/ + +/* HAS_SAFE_BCOPY: + * This symbol, if defined, indicates that the bcopy routine is available + * to copy potentially overlapping memory blocks. Otherwise you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +/*#define HAS_SAFE_BCOPY /**/ + +/* HAS_SAFE_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy potentially overlapping memory blocks. Otherwise you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +/*#define HAS_SAFE_MEMCPY /**/ + +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +#define HAS_SANE_MEMCMP /**/ + +/* HAS_SELECT: + * This symbol, if defined, indicates that the select routine is + * available to select active file descriptors. If the timeout field + * is used, <sys/time.h> may need to be included. + */ +#define HAS_SELECT /**/ + +/* HAS_SEM: + * This symbol, if defined, indicates that the entire sem*(2) library is + * supported. + */ +/*#define HAS_SEM /**/ + +/* HAS_SETEGID: + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +/*#define HAS_SETEGID /**/ + +/* HAS_SETEUID: + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +/*#define HAS_SETEUID /**/ + +/* HAS_SETLINEBUF: + * This symbol, if defined, indicates that the setlinebuf routine is + * available to change stderr or stdout from block-buffered or unbuffered + * to a line-buffered mode. + */ +/*#define HAS_SETLINEBUF /**/ + +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +#define HAS_SETLOCALE /**/ + +/* HAS_SETPGRP2: + * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) + * routine is available to set the current process group. + */ +/*#define HAS_SETPGRP2 /**/ + +/* HAS_SETPRIORITY: + * This symbol, if defined, indicates that the setpriority routine is + * available to set a process's priority. + */ +/*#define HAS_SETPRIORITY /**/ + +/* HAS_SETREGID: + * This symbol, if defined, indicates that the setregid routine is + * available to change the real and effective gid of the current + * process. + */ +/* HAS_SETRESGID: + * This symbol, if defined, indicates that the setresgid routine is + * available to change the real, effective and saved gid of the current + * process. + */ +/*#define HAS_SETREGID /**/ +/*#define HAS_SETRESGID /**/ + +/* HAS_SETREUID: + * This symbol, if defined, indicates that the setreuid routine is + * available to change the real and effective uid of the current + * process. + */ +/* HAS_SETRESUID: + * This symbol, if defined, indicates that the setresuid routine is + * available to change the real, effective and saved uid of the current + * process. + */ +/*#define HAS_SETREUID /**/ +/*#define HAS_SETRESUID /**/ + +/* HAS_SETRGID: + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +/*#define HAS_SETRGID /**/ + +/* HAS_SETRUID: + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +/*#define HAS_SETRUID /**/ + +/* HAS_SETSID: + * This symbol, if defined, indicates that the setsid routine is + * available to set the process group ID. + */ +/*#define HAS_SETSID /**/ + +/* HAS_SHM: + * This symbol, if defined, indicates that the entire shm*(2) library is + * supported. + */ +/*#define HAS_SHM /**/ + +/* Shmat_t: + * This symbol holds the return type of the shmat() system call. + * Usually set to 'void *' or 'char *'. + */ +/* HAS_SHMAT_PROTOTYPE: + * This symbol, if defined, indicates that the sys/shm.h includes + * a prototype for shmat(). Otherwise, it is up to the program to + * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, + * but not always right so it should be emitted by the program only + * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. + */ +#define Shmat_t void * /**/ +/*#define HAS_SHMAT_PROTOTYPE /**/ + +/* HAS_SIGACTION: + * This symbol, if defined, indicates that Vr4's sigaction() routine + * is available. + */ +/*#define HAS_SIGACTION /**/ + +/* HAS_SOCKET: + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* HAS_SOCKETPAIR: + * This symbol, if defined, indicates that the BSD socketpair() call is + * supported. + */ +#define HAS_SOCKET /**/ +/*#define HAS_SOCKETPAIR /**/ + +/* USE_STAT_BLOCKS: + * This symbol is defined if this system has a stat structure declaring + * st_blksize and st_blocks. + */ +/*#define USE_STAT_BLOCKS /**/ + +/* USE_STDIO_PTR: + * This symbol is defined if the _ptr and _cnt fields (or similar) + * of the stdio FILE structure can be used to access the stdio buffer + * for a file handle. If this is defined, then the FILE_ptr(fp) + * and FILE_cnt(fp) macros will also be defined and should be used + * to access these fields. + */ +/* FILE_ptr: + * This macro is used to access the _ptr field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_PTR_LVALUE: + * This symbol is defined if the FILE_ptr macro can be used as an + * lvalue. + */ +/* FILE_cnt: + * This macro is used to access the _cnt field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_CNT_LVALUE: + * This symbol is defined if the FILE_cnt macro can be used as an + * lvalue. + */ +#define USE_STDIO_PTR /**/ +#ifdef USE_STDIO_PTR +#define FILE_ptr(fp) ((fp)->curp) +#define STDIO_PTR_LVALUE /**/ +#define FILE_cnt(fp) ((fp)->level) +#define STDIO_CNT_LVALUE /**/ +#endif + +/* USE_STDIO_BASE: + * This symbol is defined if the _base field (or similar) of the + * stdio FILE structure can be used to access the stdio buffer for + * a file handle. If this is defined, then the FILE_base(fp) macro + * will also be defined and should be used to access this field. + * Also, the FILE_bufsiz(fp) macro will be defined and should be used + * to determine the number of bytes in the buffer. USE_STDIO_BASE + * will never be defined unless USE_STDIO_PTR is. + */ +/* FILE_base: + * This macro is used to access the _base field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_BASE is defined. + */ +/* FILE_bufsiz: + * This macro is used to determine the number of bytes in the I/O + * buffer pointed to by _base field (or equivalent) of the FILE + * structure pointed to its argument. This macro will always be defined + * if USE_STDIO_BASE is defined. + */ +#define USE_STDIO_BASE /**/ +#ifdef USE_STDIO_BASE +#define FILE_base(fp) ((fp)->buffer) +#define FILE_bufsiz(fp) ((fp)->level + (fp)->curp - (fp)->buffer) +#endif + +/* HAS_STRCHR: + * This symbol is defined to indicate that the strchr()/strrchr() + * functions are available for string searching. If not, try the + * index()/rindex() pair. + */ +/* HAS_INDEX: + * This symbol is defined to indicate that the index()/rindex() + * functions are available for string searching. + */ +#define HAS_STRCHR /**/ +/*#define HAS_INDEX /**/ + +/* HAS_STRCOLL: + * This symbol, if defined, indicates that the strcoll routine is + * available to compare strings using collating information. + */ +#define HAS_STRCOLL /**/ + +/* USE_STRUCT_COPY: + * This symbol, if defined, indicates that this C compiler knows how + * to copy structures. If undefined, you'll need to use a block copy + * routine of some sort instead. + */ +#define USE_STRUCT_COPY /**/ + +/* HAS_STRERROR: + * This symbol, if defined, indicates that the strerror routine is + * available to translate error numbers to strings. See the writeup + * of Strerror() in this file before you try to define your own. + */ +/* HAS_SYS_ERRLIST: + * This symbol, if defined, indicates that the sys_errlist array is + * available to translate error numbers to strings. The extern int + * sys_nerr gives the size of that table. + */ +/* Strerror: + * This preprocessor symbol is defined as a macro if strerror() is + * not available to translate error numbers to strings but sys_errlist[] + * array is there. + */ +#define HAS_STRERROR /**/ +#define HAS_SYS_ERRLIST /**/ +#define Strerror(e) strerror(e) + +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to provide better numeric string conversion than atof(). + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + +/* HAS_STRXFRM: + * This symbol, if defined, indicates that the strxfrm() routine is + * available to transform strings. + */ +#define HAS_STRXFRM /**/ + +/* HAS_SYMLINK: + * This symbol, if defined, indicates that the symlink routine is available + * to create symbolic links. + */ +/*#define HAS_SYMLINK /**/ + +/* HAS_SYSCALL: + * This symbol, if defined, indicates that the syscall routine is + * available to call arbitrary system calls. If undefined, that's tough. + */ +/*#define HAS_SYSCALL /**/ + +/* HAS_SYSCONF: + * This symbol, if defined, indicates that sysconf() is available + * to determine system related limits and options. + */ +/*#define HAS_SYSCONF /**/ + +/* HAS_SYSTEM: + * This symbol, if defined, indicates that the system routine is + * available to issue a shell command. + */ +#define HAS_SYSTEM /**/ + +/* HAS_TCGETPGRP: + * This symbol, if defined, indicates that the tcgetpgrp routine is + * available to get foreground process group ID. + */ +/*#define HAS_TCGETPGRP /**/ + +/* HAS_TCSETPGRP: + * This symbol, if defined, indicates that the tcsetpgrp routine is + * available to set foreground process group ID. + */ +/*#define HAS_TCSETPGRP /**/ + +/* Time_t: + * This symbol holds the type returned by time(). It can be long, + * or time_t on BSD sites (in which case <sys/types.h> should be + * included). + */ +#define Time_t time_t /* Time type */ + +/* HAS_TIMES: + * This symbol, if defined, indicates that the times() routine exists. + * Note that this became obsolete on some systems (SUNOS), which now + * use getrusage(). It may be necessary to include <sys/times.h>. + */ +#define HAS_TIMES /**/ + +/* HAS_TRUNCATE: + * This symbol, if defined, indicates that the truncate routine is + * available to truncate files. + */ +/*#define HAS_TRUNCATE /**/ + +/* HAS_TZNAME: + * This symbol, if defined, indicates that the tzname[] array is + * available to access timezone names. + */ +#define HAS_TZNAME /**/ + +/* HAS_UMASK: + * This symbol, if defined, indicates that the umask routine is + * available to set and get the value of the file creation mask. + */ +#define HAS_UMASK /**/ + +/* HAS_VFORK: + * This symbol, if defined, indicates that vfork() exists. + */ +/*#define HAS_VFORK /**/ + +/* Signal_t: + * This symbol's value is either "void" or "int", corresponding to the + * appropriate return type of a signal handler. Thus, you can declare + * a signal handler using "Signal_t (*handler)()", and define the + * handler using "Signal_t handler(sig)". + */ +#define Signal_t void /* Signal handler's return type */ + +/* HASVOLATILE: + * This symbol, if defined, indicates that this C compiler knows about + * the volatile declaration. + */ +#define HASVOLATILE /**/ +#ifndef HASVOLATILE +#define volatile +#endif + +/* HAS_VPRINTF: + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* USE_CHAR_VSPRINTF: + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +#define HAS_VPRINTF /**/ +/*#define USE_CHAR_VSPRINTF /**/ + +/* HAS_WAIT4: + * This symbol, if defined, indicates that wait4() exists. + */ +/*#define HAS_WAIT4 /**/ + +/* HAS_WAITPID: + * This symbol, if defined, indicates that the waitpid routine is + * available to wait for child process. + */ +/*#define HAS_WAITPID /**/ + +/* HAS_WCSTOMBS: + * This symbol, if defined, indicates that the wcstombs routine is + * available to convert wide character strings to multibyte strings. + */ +#define HAS_WCSTOMBS /**/ + +/* HAS_WCTOMB: + * This symbol, if defined, indicates that the wctomb routine is available + * to covert a wide character to a multibyte. + */ +#define HAS_WCTOMB /**/ + +/* Fpos_t: + * This symbol holds the type used to declare file positions in libc. + * It can be fpos_t, long, uint, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Fpos_t fpos_t /* File position type */ + +/* Gid_t: + * This symbol holds the return type of getgid() and the type of + * argument to setrgid() and related functions. Typically, + * it is the type of group ids in the kernel. It can be int, ushort, + * uid_t, etc... It may be necessary to include <sys/types.h> to get + * any typedef'ed information. + */ +#define Gid_t gid_t /* Type for getgid(), etc... */ + +/* Groups_t: + * This symbol holds the type used for the second argument to + * [gs]etgroups(). Usually, this is the same of gidtype, but + * sometimes it isn't. It can be int, ushort, uid_t, etc... + * It may be necessary to include <sys/types.h> to get any + * typedef'ed information. This is only required if you have + * getgroups() or setgroups(). + */ +#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) +#define Groups_t gid_t /* Type for 2nd arg to [gs]etgroups() */ +#endif + +/* DB_Prefix_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is u_int32_t. + */ +/* DB_Hash_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is size_t. + */ +#define DB_Hash_t int /**/ +#define DB_Prefix_t int /**/ + +/* I_DIRENT: + * This symbol, if defined, indicates to the C program that it should + * include <dirent.h>. Using this symbol also triggers the definition + * of the Direntry_t define which ends up being 'struct dirent' or + * 'struct direct' depending on the availability of <dirent.h>. + */ +/* DIRNAMLEN: + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +/* Direntry_t: + * This symbol is set to 'struct direct' or 'struct dirent' depending on + * whether dirent is available or not. You should use this pseudo type to + * portably declare your directory entries. + */ +#define I_DIRENT /**/ +#define DIRNAMLEN /**/ +#define Direntry_t struct direct + +/* I_DLFCN: + * This symbol, if defined, indicates that <dlfcn.h> exists and should + * be included. + */ +#define I_DLFCN /**/ + +/* I_FCNTL: + * This manifest constant tells the C program to include <fcntl.h>. + */ +#define I_FCNTL /**/ + +/* I_FLOAT: + * This symbol, if defined, indicates to the C program that it should + * include <float.h> to get definition of symbols like DBL_MAX or + * DBL_MIN, i.e. machine dependent floating point values. + */ +#define I_FLOAT /**/ + +/* I_GRP: + * This symbol, if defined, indicates to the C program that it should + * include <grp.h>. + */ +#define I_GRP /**/ + +/* I_LIMITS: + * This symbol, if defined, indicates to the C program that it should + * include <limits.h> to get definition of symbols like WORD_BIT or + * LONG_MAX, i.e. machine dependant limitations. + */ +#define I_LIMITS /**/ + +/* I_MATH: + * This symbol, if defined, indicates to the C program that it should + * include <math.h>. + */ +#define I_MATH /**/ + +/* I_MEMORY: + * This symbol, if defined, indicates to the C program that it should + * include <memory.h>. + */ +/*#define I_MEMORY /**/ + +/* I_NDBM: + * This symbol, if defined, indicates that <ndbm.h> exists and should + * be included. + */ +/*#define I_NDBM /**/ + +/* I_NET_ERRNO: + * This symbol, if defined, indicates that <net/errno.h> exists and + * should be included. + */ +/*#define I_NET_ERRNO /**/ + +/* I_NETINET_IN: + * This symbol, if defined, indicates to the C program that it should + * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. + */ +/*#define I_NETINET_IN /**/ + +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include <pwd.h>. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +/*#define I_PWD /**/ +/*#define PWQUOTA /**/ +/*#define PWAGE /**/ +/*#define PWCHANGE /**/ +/*#define PWCLASS /**/ +/*#define PWEXPIRE /**/ +/*#define PWCOMMENT /**/ + +/* I_STDDEF: + * This symbol, if defined, indicates that <stddef.h> exists and should + * be included. + */ +#define I_STDDEF /**/ + +/* I_STDLIB: + * This symbol, if defined, indicates that <stdlib.h> exists and should + * be included. + */ +#define I_STDLIB /**/ + +/* I_STRING: + * This symbol, if defined, indicates to the C program that it should + * include <string.h> (USG systems) instead of <strings.h> (BSD systems). + */ +#define I_STRING /**/ + +/* I_SYS_DIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/dir.h>. + */ +/*#define I_SYS_DIR /**/ + +/* I_SYS_FILE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/file.h> to get definition of R_OK and friends. + */ +/*#define I_SYS_FILE /**/ + +/* I_SYS_IOCTL: + * This symbol, if defined, indicates that <sys/ioctl.h> exists and should + * be included. Otherwise, include <sgtty.h> or <termio.h>. + */ +/*#define I_SYS_IOCTL /**/ + +/* I_SYS_NDIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/ndir.h>. + */ +/*#define I_SYS_NDIR /**/ + +/* I_SYS_PARAM: + * This symbol, if defined, indicates to the C program that it should + * include <sys/param.h>. + */ +/*#define I_SYS_PARAM /**/ + +/* I_SYS_RESOURCE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/resource.h>. + */ +/*#define I_SYS_RESOURCE /**/ + +/* I_SYS_SELECT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/select.h> in order to get definition of struct timeval. + */ +/*#define I_SYS_SELECT /**/ + +/* I_SYS_TIMES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/times.h>. + */ +/*#define I_SYS_TIMES /**/ + +/* I_SYS_TYPES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/types.h>. + */ +#define I_SYS_TYPES /**/ + +/* I_SYS_UN: + * This symbol, if defined, indicates to the C program that it should + * include <sys/un.h> to get UNIX domain socket definitions. + */ +/*#define I_SYS_UN /**/ + +/* I_SYS_WAIT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/wait.h>. + */ +/*#define I_SYS_WAIT /**/ + +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * <termio.h> rather than <sgtty.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * <sgtty.h> rather than <termio.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/*#define I_TERMIO /**/ +/*#define I_TERMIOS /**/ +/*#define I_SGTTY /**/ + +/* I_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <time.h>. + */ +/* I_SYS_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h>. + */ +/* I_SYS_TIME_KERNEL: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h> with KERNEL defined. + */ +#define I_TIME /**/ +/*#define I_SYS_TIME /**/ +/*#define I_SYS_TIME_KERNEL /**/ + +/* I_UNISTD: + * This symbol, if defined, indicates to the C program that it should + * include <unistd.h>. + */ +/*#define I_UNISTD /**/ + +/* I_UTIME: + * This symbol, if defined, indicates to the C program that it should + * include <utime.h>. + */ +#define I_UTIME /**/ + +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include <varargs.h>. + */ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +/*#define I_VFORK /**/ + +/* INTSIZE: + * This symbol contains the value of sizeof(int) so that the C + * preprocessor can make decisions based on it. + */ +/* LONGSIZE: + * This symbol contains the value of sizeof(long) so that the C + * preprocessor can make decisions based on it. + */ +/* SHORTSIZE: + * This symbol contains the value of sizeof(short) so that the C + * preprocessor can make decisions based on it. + */ +#define INTSIZE 4 /**/ +#define LONGSIZE 4 /**/ +#define SHORTSIZE 2 /**/ + +/* Off_t: + * This symbol holds the type used to declare offsets in the kernel. + * It can be int, long, off_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Off_t off_t /* <offset> type */ + +/* Mode_t: + * This symbol holds the type used to declare file modes + * for systems calls. It is usually mode_t, but may be + * int or unsigned short. It may be necessary to include <sys/types.h> + * to get any typedef'ed information. + */ +#define Mode_t mode_t /* file mode parameter for system calls */ + +/* VAL_O_NONBLOCK: + * This symbol is to be used during open() or fcntl(F_SETFL) to turn on + * non-blocking I/O for the file descriptor. Note that there is no way + * back, i.e. you cannot turn it blocking again this way. If you wish to + * alternatively switch between blocking and non-blocking, use the + * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. + */ +/* VAL_EAGAIN: + * This symbol holds the errno error code set by read() when no data was + * present on the non-blocking file descriptor. + */ +/* RD_NODATA: + * This symbol holds the return code from read() when no data is present + * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is + * not defined, then you can't distinguish between no data and EOF by + * issuing a read(). You'll have to find another way to tell for sure! + */ +/* EOF_NONBLOCK: + * This symbol, if defined, indicates to the C program that a read() on + * a non-blocking file descriptor will return 0 on EOF, and not the value + * held in RD_NODATA (-1 usually, in that case!). + */ +#define VAL_O_NONBLOCK O_NONBLOCK +#define VAL_EAGAIN EAGAIN +#define RD_NODATA -1 +#define EOF_NONBLOCK + +/* CAN_PROTOTYPE: + * If defined, this macro indicates that the C compiler can handle + * function prototypes. + */ +/* _: + * This macro is used to declare function parameters for folks who want + * to make declarations with prototypes using a different style than + * the above macros. Use double parentheses. For example: + * + * int main _((int argc, char *argv[])); + */ +#define CAN_PROTOTYPE /**/ +#ifdef CAN_PROTOTYPE +#define _(args) args +#else +#define _(args) () +#endif + +/* RANDBITS: + * This symbol contains the number of bits of random number the rand() + * function produces. Usual values are 15, 16, and 31. + */ +#define RANDBITS 15 /**/ + +/* Select_fd_set_t: + * This symbol holds the type used for the 2nd, 3rd, and 4th + * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET + * is defined, and 'int *' otherwise. This is only useful if you + * have select(), of course. + */ +#define Select_fd_set_t int * /**/ + +/* Size_t: + * This symbol holds the type used to declare length parameters + * for string functions. It is usually size_t, but may be + * unsigned long, int, etc. It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Size_t size_t /* length paramater for string functions */ + +/* SSize_t: + * This symbol holds the type used by functions that return + * a count of bytes or an error condition. It must be a signed type. + * It is usually ssize_t, but may be long or int, etc. + * It may be necessary to include <sys/types.h> or <unistd.h> + * to get any typedef'ed information. + * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). + */ +#define SSize_t int /* signed count of bytes */ + +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR unsigned char /**/ + +/* Uid_t: + * This symbol holds the type used to declare user ids in the kernel. + * It can be int, ushort, uid_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Uid_t uid_t /* UID type */ + +/* LOC_SED: + * This symbol holds the complete pathname to the sed program. + */ +#define LOC_SED "" /**/ + +/* OSNAME: + * This symbol contains the name of the operating system, as determined + * by Configure. You shouldn't rely on it too much; the specific + * feature tests from Configure are generally more reliable. + */ +#define OSNAME "MSWin32" /**/ + +/* ARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user wants to put architecture-dependent public + * library files for perl5. It is most often a local directory + * such as /usr/local/lib. Programs using this variable must be + * prepared to deal with filename expansion. If ARCHLIB is the + * same as PRIVLIB, it is not defined, since presumably the + * program already searches PRIVLIB. + */ +/* ARCHLIB_EXP: + * This symbol contains the ~name expanded version of ARCHLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define ARCHLIB "c:\\perl\\lib" /**/ +#define ARCHLIB_EXP (win32PerlLibPath()) /**/ + +/* BINCOMPAT3: + * This symbol, if defined, indicates that Perl 5.004 should be + * binary-compatible with Perl 5.003. + */ +/*#define BINCOMPAT3 /**/ + +/* BYTEORDER: + * This symbol holds the hexadecimal constant defined in byteorder, + * i.e. 0x1234 or 0x4321, etc... + * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture + * Binaries (MAB) on either big endian or little endian machines. + * The endian-ness is available at compile-time. This only matters + * for perl, where the config.h can be generated and installed on + * one system, and used by a different architecture to build an + * extension. Older versions of NeXT that might not have + * defined either *_ENDIAN__ were all on Motorola 680x0 series, + * so the default case (for NeXT) is big endian to catch them. + * This might matter for NeXT 3.0. + */ +#ifndef NeXT +#define BYTEORDER 0x1234 /* large digits for MSB */ +#else /* NeXT */ +#ifdef __LITTLE_ENDIAN__ +#define BYTEORDER 0x1234 +#else /* __BIG_ENDIAN__ */ +#define BYTEORDER 0x4321 +#endif /* ENDIAN CHECK */ +#endif /* NeXT */ + +/* CSH: + * This symbol, if defined, indicates that the C-shell exists. + * If defined, contains the full pathname of csh. + */ +/*#define CSH "" /**/ + +/* DLSYM_NEEDS_UNDERSCORE: + * This symbol, if defined, indicates that we need to prepend an + * underscore to the symbol name before calling dlsym(). This only + * makes sense if you *have* dlsym, which we will presume is the + * case if you're using dl_dlopen.xs. + */ +/*#define DLSYM_NEEDS_UNDERSCORE /**/ + +/* SETUID_SCRIPTS_ARE_SECURE_NOW: + * This symbol, if defined, indicates that the bug that prevents + * setuid scripts from being secure is not present in this kernel. + */ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +/*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +/*#define DOSUID /**/ + +/* Gconvert: + * This preprocessor macro is defined to convert a floating point + * number to a string without a trailing decimal point. This + * emulates the behavior of sprintf("%g"), but is sometimes much more + * efficient. If gconvert() is not available, but gcvt() drops the + * trailing decimal point, then gcvt() is used. If all else fails, + * a macro using sprintf("%g") is used. Arguments for the Gconvert + * macro are: value, number of digits, whether trailing zeros should + * be retained, and the output buffer. + * Possible values are: + * d_Gconvert='gconvert((x),(n),(t),(b))' + * d_Gconvert='gcvt((x),(n),(b))' + * d_Gconvert='sprintf((b),"%.*g",(n),(x))' + * The last two assume trailing zeros should not be kept. + */ +#define Gconvert(x,n,t,b) gcvt((x),(n),(b)) + +/* HAS_GETPGID: + * This symbol, if defined, indicates to the C program that + * the getpgid(pid) function is available to get the + * process group id. + */ +/*#define HAS_GETPGID /**/ + +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +/*#define HAS_GETPGRP /**/ +/*#define USE_BSD_GETPGRP /**/ + +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +/*#define HAS_INET_ATON /**/ + +/* HAS_SETPGID: + * This symbol, if defined, indicates to the C program that + * the setpgid(pid, gpid) function is available to set the + * process group id. + */ +/*#define HAS_SETPGID /**/ + +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +/* USE_BSDPGRP: + * This symbol, if defined, indicates that the BSD notion of process + * group is to be used. For instance, you have to say setpgrp(pid, pgrp) + * instead of the USG setpgrp(). This should be obsolete since + * there are systems which have BSD-ish setpgrp but USG-ish getpgrp. + */ +/*#define HAS_SETPGRP /**/ +/*#define USE_BSD_SETPGRP /**/ +/*#define USE_BSDPGRP /**/ + +/* USE_SFIO: + * This symbol, if defined, indicates that sfio should + * be used. + */ +/*#define USE_SFIO /**/ + +/* Sigjmp_buf: + * This is the buffer type to be used with Sigsetjmp and Siglongjmp. + */ +/* Sigsetjmp: + * This macro is used in the same way as sigsetjmp(), but will invoke + * traditional setjmp() if sigsetjmp isn't available. + * See HAS_SIGSETJMP. + */ +/* Siglongjmp: + * This macro is used in the same way as siglongjmp(), but will invoke + * traditional longjmp() if siglongjmp isn't available. + * See HAS_SIGSETJMP. + */ +/*#define HAS_SIGSETJMP /**/ +#ifdef HAS_SIGSETJMP +#define Sigjmp_buf sigjmp_buf +#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) +#define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) +#else +#define Sigjmp_buf jmp_buf +#define Sigsetjmp(buf,save_mask) setjmp((buf)) +#define Siglongjmp(buf,retval) longjmp((buf),(retval)) +#endif + +/* USE_DYNAMIC_LOADING: + * This symbol, if defined, indicates that dynamic loading of + * some sort is available. + */ +#define USE_DYNAMIC_LOADING /**/ + +/* I_DBM: + * This symbol, if defined, indicates that <dbm.h> exists and should + * be included. + */ +/* I_RPCSVC_DBM: + * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and + * should be included. + */ +/*#define I_DBM /**/ +#define I_RPCSVC_DBM /**/ + +/* I_LOCALE: + * This symbol, if defined, indicates to the C program that it should + * include <locale.h>. + */ +#define I_LOCALE /**/ + +/* I_SFIO: + * This symbol, if defined, indicates to the C program that it should + * include <sfio.h>. + */ +/*#define I_SFIO /**/ + +/* I_SYS_STAT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/stat.h>. + */ +#define I_SYS_STAT /**/ + +/* I_VALUES: + * This symbol, if defined, indicates to the C program that it should + * include <values.h> to get definition of symbols like MINFLOAT or + * MAXLONG, i.e. machine dependant limitations. Probably, you + * should use <limits.h> instead, if it is available. + */ +/*#define I_VALUES /**/ + +/* Free_t: + * This variable contains the return type of free(). It is usually + * void, but occasionally int. + */ +/* Malloc_t: + * This symbol is the type of pointer returned by malloc and realloc. + */ +#define Malloc_t void * /**/ +#define Free_t void /**/ + +/* MYMALLOC: + * This symbol, if defined, indicates that we're using our own malloc. + */ +/*#define MYMALLOC /**/ + +/* OLDARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user has perl5.000 or perl5.001 architecture-dependent + * public library files for perl5. For the most part, these + * files will work with 5.002 (and later), but that is not + * guaranteed. + */ +/* OLDARCHLIB_EXP: + * This symbol contains the ~name expanded version of OLDARCHLIB, to be + * used in programs that are not prepared to deal with ~ expansion at + * run-time. + */ +/*#define OLDARCHLIB "" /**/ +/*#define OLDARCHLIB_EXP "" /**/ + +/* PRIVLIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + */ +/* PRIVLIB_EXP: + * This symbol contains the ~name expanded version of PRIVLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define PRIVLIB "c:\\perl\\lib" /**/ +#define PRIVLIB_EXP "c:\\perl\\lib" /**/ + +/* SH_PATH: + * This symbol contains the full pathname to the shell used on this + * on this system to execute Bourne shell scripts. Usually, this will be + * /bin/sh, though it's possible that some systems will have /bin/ksh, + * /bin/pdksh, /bin/ash, /bin/bash, or even something such as + * D:/bin/sh.exe. + */ +#define SH_PATH "cmd.exe" /**/ + +/* SIG_NAME: + * This symbol contains a list of signal names in order of + * signal number. This is intended + * to be used as a static array initialization, like this: + * char *sig_name[] = { SIG_NAME }; + * The signals in the list are separated with commas, and each signal + * is surrounded by double quotes. There is no leading SIG in the signal + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). + * The signal number for sig_name[i] is stored in sig_num[i]. + * The last element is 0 to terminate the list with a NULL. This + * corresponds to the 0 at the end of the sig_num list. + */ +/* SIG_NUM: + * This symbol contains a list of signal numbers, in the same order as the + * SIG_NAME list. It is suitable for static array initialization, as in: + * int sig_num[] = { SIG_NUM }; + * The signals in the list are separated with commas, and the indices + * within that list and the SIG_NAME list match, so it's easy to compute + * the signal name from a number or vice versa at the price of a small + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name list. + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CHLD","PWR","WINCH","URG","IO","STOP","TSTP","CONT","TTIN","TTOU","VTALRM","PROF","XCPU","XFSZ","WAITING","LWP","FREEZE","THAW","RTMIN","NUM37","NUM38","NUM39","NUM40","NUM41","NUM42","RTMAX","IOT","CLD","POLL",0 /**/ +#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,6,18,22,0 /**/ + +/* SITEARCH: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * Individual sites may place their own extensions and modules in + * this directory. + */ +/* SITEARCH_EXP: + * This symbol contains the ~name expanded version of SITEARCH, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define SITEARCH "c:\\perl\\lib\\site" /**/ +#define SITEARCH_EXP "c:\\perl\\lib\\site" /**/ + +/* SITELIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * Individual sites may place their own extensions and modules in + * this directory. + */ +/* SITELIB_EXP: + * This symbol contains the ~name expanded version of SITELIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define SITELIB "c:\\perl\\lib\\site" /**/ +#define SITELIB_EXP "c:\\perl\\lib\\site" /**/ + +/* STARTPERL: + * This variable contains the string to put in front of a perl + * script to make sure (one hopes) that it runs with perl and not + * some shell. + */ +#define STARTPERL "#perl" /**/ + +/* USE_PERLIO: + * This symbol, if defined, indicates that the PerlIO abstraction should + * be used throughout. If not defined, stdio should be + * used in a fully backward compatible manner. + */ +/*#define USE_PERLIO /**/ + +/* VOIDFLAGS: + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * 8 = suports declaration of generic void pointers + * + * The package designer should define VOIDUSED to indicate the requirements + * of the package. This can be done either by #defining VOIDUSED before + * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the + * level of void support necessary is not present, defines void to int. + */ +#ifndef VOIDUSED +#define VOIDUSED 15 +#endif +#define VOIDFLAGS 15 +#if (VOIDFLAGS & VOIDUSED) != VOIDUSED +#define void int /* is void to be avoided? */ +#define M_VOID /* Xenix strikes again */ +#endif + +#endif +#include <win32.h> +#ifndef DEBUGGING +#define DEBUGGING +#endif diff --git a/gnu/usr.bin/perl/win32/config_H.vc b/gnu/usr.bin/perl/win32/config_H.vc new file mode 100644 index 00000000000..76f19f1d872 --- /dev/null +++ b/gnu/usr.bin/perl/win32/config_H.vc @@ -0,0 +1,1802 @@ +/* + * This file was produced by running the config_h.SH script, which + * gets its values from config.sh, which is generally produced by + * running Configure. + * + * Feel free to modify any of this as the need arises. Note, however, + * that running config_h.SH again will wipe out any changes you've made. + * For a more permanent change edit config.sh and rerun config_h.SH. + * + * $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ + */ + +/* Configuration time: Thu Apr 11 06:20:49 PDT 1996 + * Configured by: garyng + * Target system: + */ + +#ifndef _config_h_ +#define _config_h_ + +/* MEM_ALIGNBYTES: + * This symbol contains the number of bytes required to align a + * double. Usual values are 2, 4 and 8. + * On NeXT starting with 3.2, you can build "Fat" Multiple Architecture + * Binaries (MAB) for targets with varying alignment. This only matters + * for perl, where the config.h can be generated and installed on one + * system, and used by a different architecture to build an extension. + * The default is eight, for safety. + */ +#ifndef NeXT +#define MEM_ALIGNBYTES 8 /**/ +#else /* NeXT */ +#ifdef __m68k__ +#define MEM_ALIGNBYTES 2 +#else +#ifdef __i386__ +#define MEM_ALIGNBYTES 4 +#else /* __hppa__, __sparc__ and default for unknown architectures */ +#define MEM_ALIGNBYTES 8 +#endif /* __i386__ */ +#endif /* __m68k__ */ +#endif /* NeXT */ + +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#ifdef _ALPHA_ +#define ARCHNAME "alpha-mswin32" /**/ +#else +#define ARCHNAME "x86-mswin32" /**/ +#endif + +/* BIN: + * This symbol holds the path of the bin directory where the package will + * be installed. Program must be prepared to deal with ~name substitution. + */ +/* BIN_EXP: + * This symbol is the filename expanded version of the BIN symbol, for + * programs that do not want to deal with that at run-time. + */ +#define BIN "c:\\perl\\bin" /**/ +#define BIN_EXP "c:\\perl\\bin" /**/ + +/* CAT2: + * This macro catenates 2 tokens together. + */ +/* STRINGIFY: + * This macro surrounds its token with double quotes. + */ +#if 42 == 1 +#define CAT2(a,b)a/**/b +#define CAT3(a,b,c)a/**/b/**/c +#define CAT4(a,b,c,d)a/**/b/**/c/**/d +#define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e +#define STRINGIFY(a)"a" + /* If you can get stringification with catify, tell me how! */ +#endif +#if 42 == 42 +#define CAT2(a,b)a ## b +#define CAT3(a,b,c)a ## b ## c +#define CAT4(a,b,c,d)a ## b ## c ## d +#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e +#define StGiFy(a)# a +#define STRINGIFY(a)StGiFy(a) +#define SCAT2(a,b)StGiFy(a) StGiFy(b) +#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) +#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) +#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) +#endif +#ifndef CAT2 +#include "Bletch: How does this C preprocessor catenate tokens?" +#endif + +/* CPPSTDIN: + * This symbol contains the first part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. Typical value of "cc -E" or "/lib/cpp", but it can also + * call a wrapper. See CPPRUN. + */ +/* CPPMINUS: + * This symbol contains the second part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. This symbol will have the value "-" if CPPSTDIN needs a minus + * to specify standard input, otherwise the value is "". + */ +#define CPPSTDIN "cl -E" +#define CPPMINUS "" + +/* HAS_ALARM: + * This symbol, if defined, indicates that the alarm routine is + * available. + */ +/*#define HAS_ALARM /**/ + +/* HASATTRIBUTE: + * This symbol indicates the C compiler can check for function attributes, + * such as printf formats. This is normally only supported by GNU cc. + */ +/*#define HASATTRIBUTE /**/ +#ifndef HASATTRIBUTE +#define __attribute__(_arg_) +#endif + +/* HAS_BCMP: + * This symbol is defined if the bcmp() routine is available to + * compare blocks of memory. + */ +/*#define HAS_BCMP /**/ + +/* HAS_BCOPY: + * This symbol is defined if the bcopy() routine is available to + * copy blocks of memory. + */ +/*#define HAS_BCOPY /**/ + +/* HAS_BZERO: + * This symbol is defined if the bzero() routine is available to + * set a memory block to 0. + */ +/*#define HAS_BZERO /**/ + +/* CASTI32: + * This symbol is defined if the C compiler can cast negative + * or large floating point numbers to 32-bit ints. + */ +#define CASTI32 /**/ + +/* CASTNEGFLOAT: + * This symbol is defined if the C compiler can cast negative + * numbers to unsigned longs, ints and shorts. + */ +/* CASTFLAGS: + * This symbol contains flags that say what difficulties the compiler + * has casting odd floating values to unsigned long: + * 0 = ok + * 1 = couldn't cast < 0 + * 2 = couldn't cast >= 0x80000000 + * 4 = couldn't cast in argument expression list + */ +#define CASTNEGFLOAT /**/ +#define CASTFLAGS 0 /**/ + +/* HAS_CHOWN: + * This symbol, if defined, indicates that the chown routine is + * available. + */ +/*#define HAS_CHOWN /**/ + +/* HAS_CHROOT: + * This symbol, if defined, indicates that the chroot routine is + * available. + */ +/*#define HAS_CHROOT /**/ + +/* HAS_CHSIZE: + * This symbol, if defined, indicates that the chsize routine is available + * to truncate files. You might need a -lx to get this routine. + */ +#define HAS_CHSIZE /**/ + +/* VOID_CLOSEDIR: + * This symbol, if defined, indicates that the closedir() routine + * does not return a value. + */ +/*#define VOID_CLOSEDIR /**/ + +/* HASCONST: + * This symbol, if defined, indicates that this C compiler knows about + * the const type. There is no need to actually test for that symbol + * within your programs. The mere use of the "const" keyword will + * trigger the necessary tests. + */ +#define HASCONST /**/ +#ifndef HASCONST +#define const +#endif + +/* HAS_CRYPT: + * This symbol, if defined, indicates that the crypt routine is available + * to encrypt passwords and the like. + */ +/*#define HAS_CRYPT /**/ + +/* HAS_CUSERID: + * This symbol, if defined, indicates that the cuserid routine is + * available to get character login names. + */ +/*#define HAS_CUSERID /**/ + +/* HAS_DBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol DBL_DIG, which is the number + * of significant digits in a double precision number. If this + * symbol is not defined, a guess of 15 is usually pretty good. + */ +#define HAS_DBL_DIG /**/ + +/* HAS_DIFFTIME: + * This symbol, if defined, indicates that the difftime routine is + * available. + */ +#define HAS_DIFFTIME /**/ + +/* HAS_DLERROR: + * This symbol, if defined, indicates that the dlerror routine is + * available to return a string describing the last error that + * occurred from a call to dlopen(), dlclose() or dlsym(). + */ +#define HAS_DLERROR /**/ + +/* HAS_DUP2: + * This symbol, if defined, indicates that the dup2 routine is + * available to duplicate file descriptors. + */ +#define HAS_DUP2 /**/ + +/* HAS_FCHMOD: + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +/*#define HAS_FCHMOD /**/ + +/* HAS_FCHOWN: + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +/*#define HAS_FCHOWN /**/ + +/* HAS_FCNTL: + * This symbol, if defined, indicates to the C program that + * the fcntl() function exists. + */ +/*#define HAS_FCNTL /**/ + +/* HAS_FGETPOS: + * This symbol, if defined, indicates that the fgetpos routine is + * available to get the file position indicator, similar to ftell(). + */ +#define HAS_FGETPOS /**/ + +/* FLEXFILENAMES: + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#define FLEXFILENAMES /**/ + +/* HAS_FLOCK: + * This symbol, if defined, indicates that the flock routine is + * available to do file locking. + */ +#define HAS_FLOCK /**/ + +/* HAS_FORK: + * This symbol, if defined, indicates that the fork routine is + * available. + */ +/*#define HAS_FORK /**/ + +/* HAS_FSETPOS: + * This symbol, if defined, indicates that the fsetpos routine is + * available to set the file position indicator, similar to fseek(). + */ +#define HAS_FSETPOS /**/ + +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). + * The type "Timeval" should be used to refer to "struct timeval". + */ +/*#define HAS_GETTIMEOFDAY /**/ +#ifdef HAS_GETTIMEOFDAY +#define Timeval struct timeval /* Structure used by gettimeofday() */ +#endif + +/* HAS_GETGROUPS: + * This symbol, if defined, indicates that the getgroups() routine is + * available to get the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +/* HAS_SETGROUPS: + * This symbol, if defined, indicates that the setgroups() routine is + * available to set the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +/*#define HAS_GETGROUPS /**/ +/*#define HAS_SETGROUPS /**/ + +/* HAS_GETHOSTENT: + * This symbol, if defined, indicates that the gethostent routine is + * available to lookup host names in some data base or other. + */ +/*#define HAS_GETHOSTENT /**/ + +/* HAS_UNAME: + * This symbol, if defined, indicates that the C program may use the + * uname() routine to derive the host name. See also HAS_GETHOSTNAME + * and PHOSTNAME. + */ +/*#define HAS_UNAME /**/ + +/* HAS_GETLOGIN: + * This symbol, if defined, indicates that the getlogin routine is + * available to get the login name. + */ +/*#define HAS_GETLOGIN /**/ + +/* HAS_GETPGRP2: + * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) + * routine is available to get the current process group. + */ +/*#define HAS_GETPGRP2 /**/ + +/* HAS_GETPPID: + * This symbol, if defined, indicates that the getppid routine is + * available to get the parent process ID. + */ +/*#define HAS_GETPPID /**/ + +/* HAS_GETPRIORITY: + * This symbol, if defined, indicates that the getpriority routine is + * available to get a process's priority. + */ +/*#define HAS_GETPRIORITY /**/ + +/* HAS_HTONL: + * This symbol, if defined, indicates that the htonl() routine (and + * friends htons() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_HTONS: + * This symbol, if defined, indicates that the htons() routine (and + * friends htonl() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHL: + * This symbol, if defined, indicates that the ntohl() routine (and + * friends htonl() htons() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHS: + * This symbol, if defined, indicates that the ntohs() routine (and + * friends htonl() htons() ntohl()) are available to do network + * order byte swapping. + */ +#define HAS_HTONL /**/ +#define HAS_HTONS /**/ +#define HAS_NTOHL /**/ +#define HAS_NTOHS /**/ + +/* HAS_ISASCII: + * This manifest constant lets the C program know that isascii + * is available. + */ +#define HAS_ISASCII /**/ + +/* HAS_KILLPG: + * This symbol, if defined, indicates that the killpg routine is available + * to kill process groups. If unavailable, you probably should use kill + * with a negative process number. + */ +/*#define HAS_KILLPG /**/ + +/* HAS_LINK: + * This symbol, if defined, indicates that the link routine is + * available to create hard links. + */ +/*#define HAS_LINK /**/ + +/* HAS_LOCALECONV: + * This symbol, if defined, indicates that the localeconv routine is + * available for numeric and monetary formatting conventions. + */ +#define HAS_LOCALECONV /**/ + +/* HAS_LOCKF: + * This symbol, if defined, indicates that the lockf routine is + * available to do file locking. + */ +/*#define HAS_LOCKF /**/ + +/* HAS_LSTAT: + * This symbol, if defined, indicates that the lstat routine is + * available to do file stats on symbolic links. + */ +/*#define HAS_LSTAT /**/ + +/* HAS_MBLEN: + * This symbol, if defined, indicates that the mblen routine is available + * to find the number of bytes in a multibye character. + */ +#define HAS_MBLEN /**/ + +/* HAS_MBSTOWCS: + * This symbol, if defined, indicates that the mbstowcs routine is + * available to covert a multibyte string into a wide character string. + */ +#define HAS_MBSTOWCS /**/ + +/* HAS_MBTOWC: + * This symbol, if defined, indicates that the mbtowc routine is available + * to covert a multibyte to a wide character. + */ +#define HAS_MBTOWC /**/ + +/* HAS_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. + */ +#define HAS_MEMCMP /**/ + +/* HAS_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy blocks of memory. + */ +#define HAS_MEMCPY /**/ + +/* HAS_MEMMOVE: + * This symbol, if defined, indicates that the memmove routine is available + * to copy potentially overlapping blocks of memory. This should be used + * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your + * own version. + */ +#define HAS_MEMMOVE /**/ + +/* HAS_MEMSET: + * This symbol, if defined, indicates that the memset routine is available + * to set blocks of memory. + */ +#define HAS_MEMSET /**/ + +/* HAS_MKDIR: + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#define HAS_MKDIR /**/ + +/* HAS_MKFIFO: + * This symbol, if defined, indicates that the mkfifo routine is + * available to create FIFOs. Otherwise, mknod should be able to + * do it for you. However, if mkfifo is there, mknod might require + * super-user privileges which mkfifo will not. + */ +/*#define HAS_MKFIFO /**/ + +/* HAS_MKTIME: + * This symbol, if defined, indicates that the mktime routine is + * available. + */ +#define HAS_MKTIME /**/ + +/* HAS_MSG: + * This symbol, if defined, indicates that the entire msg*(2) library is + * supported (IPC mechanism based on message queues). + */ +/*#define HAS_MSG /**/ + +/* HAS_NICE: + * This symbol, if defined, indicates that the nice routine is + * available. + */ +/*#define HAS_NICE /**/ + +/* HAS_OPEN3: + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. + */ +/*#define HAS_OPEN3 /**/ + +/* HAS_PATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given filename. + */ +/* HAS_FPATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given open file descriptor. + */ +/*#define HAS_PATHCONF /**/ +/*#define HAS_FPATHCONF /**/ + +/* HAS_PAUSE: + * This symbol, if defined, indicates that the pause routine is + * available to suspend a process until a signal is received. + */ +#define HAS_PAUSE /**/ + +/* HAS_PIPE: + * This symbol, if defined, indicates that the pipe routine is + * available to create an inter-process channel. + */ +#define HAS_PIPE /**/ + +/* HAS_POLL: + * This symbol, if defined, indicates that the poll routine is + * available to poll active file descriptors. + */ +/*#define HAS_POLL /**/ + +/* HAS_READDIR: + * This symbol, if defined, indicates that the readdir routine is + * available to read directory entries. You may have to include + * <dirent.h>. See I_DIRENT. + */ +#define HAS_READDIR /**/ + +/* HAS_SEEKDIR: + * This symbol, if defined, indicates that the seekdir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_SEEKDIR /**/ + +/* HAS_TELLDIR: + * This symbol, if defined, indicates that the telldir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_TELLDIR /**/ + +/* HAS_REWINDDIR: + * This symbol, if defined, indicates that the rewinddir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_REWINDDIR /**/ + +/* HAS_READLINK: + * This symbol, if defined, indicates that the readlink routine is + * available to read the value of a symbolic link. + */ +/*#define HAS_READLINK /**/ + +/* HAS_RENAME: + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#define HAS_RENAME /**/ + +/* HAS_RMDIR: + * This symbol, if defined, indicates that the rmdir routine is + * available to remove directories. Otherwise you should fork off a + * new process to exec /bin/rmdir. + */ +#define HAS_RMDIR /**/ + +/* HAS_SAFE_BCOPY: + * This symbol, if defined, indicates that the bcopy routine is available + * to copy potentially overlapping memory blocks. Otherwise you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +/*#define HAS_SAFE_BCOPY /**/ + +/* HAS_SAFE_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy potentially overlapping memory blocks. Otherwise you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +/*#define HAS_SAFE_MEMCPY /**/ + +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +#define HAS_SANE_MEMCMP /**/ + +/* HAS_SELECT: + * This symbol, if defined, indicates that the select routine is + * available to select active file descriptors. If the timeout field + * is used, <sys/time.h> may need to be included. + */ +#define HAS_SELECT /**/ + +/* HAS_SEM: + * This symbol, if defined, indicates that the entire sem*(2) library is + * supported. + */ +/*#define HAS_SEM /**/ + +/* HAS_SETEGID: + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +/*#define HAS_SETEGID /**/ + +/* HAS_SETEUID: + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +/*#define HAS_SETEUID /**/ + +/* HAS_SETLINEBUF: + * This symbol, if defined, indicates that the setlinebuf routine is + * available to change stderr or stdout from block-buffered or unbuffered + * to a line-buffered mode. + */ +/*#define HAS_SETLINEBUF /**/ + +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +#define HAS_SETLOCALE /**/ + +/* HAS_SETPGRP2: + * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) + * routine is available to set the current process group. + */ +/*#define HAS_SETPGRP2 /**/ + +/* HAS_SETPRIORITY: + * This symbol, if defined, indicates that the setpriority routine is + * available to set a process's priority. + */ +/*#define HAS_SETPRIORITY /**/ + +/* HAS_SETREGID: + * This symbol, if defined, indicates that the setregid routine is + * available to change the real and effective gid of the current + * process. + */ +/* HAS_SETRESGID: + * This symbol, if defined, indicates that the setresgid routine is + * available to change the real, effective and saved gid of the current + * process. + */ +/*#define HAS_SETREGID /**/ +/*#define HAS_SETRESGID /**/ + +/* HAS_SETREUID: + * This symbol, if defined, indicates that the setreuid routine is + * available to change the real and effective uid of the current + * process. + */ +/* HAS_SETRESUID: + * This symbol, if defined, indicates that the setresuid routine is + * available to change the real, effective and saved uid of the current + * process. + */ +/*#define HAS_SETREUID /**/ +/*#define HAS_SETRESUID /**/ + +/* HAS_SETRGID: + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +/*#define HAS_SETRGID /**/ + +/* HAS_SETRUID: + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +/*#define HAS_SETRUID /**/ + +/* HAS_SETSID: + * This symbol, if defined, indicates that the setsid routine is + * available to set the process group ID. + */ +/*#define HAS_SETSID /**/ + +/* HAS_SHM: + * This symbol, if defined, indicates that the entire shm*(2) library is + * supported. + */ +/*#define HAS_SHM /**/ + +/* Shmat_t: + * This symbol holds the return type of the shmat() system call. + * Usually set to 'void *' or 'char *'. + */ +/* HAS_SHMAT_PROTOTYPE: + * This symbol, if defined, indicates that the sys/shm.h includes + * a prototype for shmat(). Otherwise, it is up to the program to + * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, + * but not always right so it should be emitted by the program only + * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. + */ +#define Shmat_t void * /**/ +/*#define HAS_SHMAT_PROTOTYPE /**/ + +/* HAS_SIGACTION: + * This symbol, if defined, indicates that Vr4's sigaction() routine + * is available. + */ +/*#define HAS_SIGACTION /**/ + +/* HAS_SOCKET: + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* HAS_SOCKETPAIR: + * This symbol, if defined, indicates that the BSD socketpair() call is + * supported. + */ +#define HAS_SOCKET /**/ +/*#define HAS_SOCKETPAIR /**/ + +/* USE_STAT_BLOCKS: + * This symbol is defined if this system has a stat structure declaring + * st_blksize and st_blocks. + */ +/*#define USE_STAT_BLOCKS /**/ + +/* USE_STDIO_PTR: + * This symbol is defined if the _ptr and _cnt fields (or similar) + * of the stdio FILE structure can be used to access the stdio buffer + * for a file handle. If this is defined, then the FILE_ptr(fp) + * and FILE_cnt(fp) macros will also be defined and should be used + * to access these fields. + */ +/* FILE_ptr: + * This macro is used to access the _ptr field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_PTR_LVALUE: + * This symbol is defined if the FILE_ptr macro can be used as an + * lvalue. + */ +/* FILE_cnt: + * This macro is used to access the _cnt field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_CNT_LVALUE: + * This symbol is defined if the FILE_cnt macro can be used as an + * lvalue. + */ +#define USE_STDIO_PTR /**/ +#ifdef USE_STDIO_PTR +#define FILE_ptr(fp) ((fp)->_ptr) +#define STDIO_PTR_LVALUE /**/ +#define FILE_cnt(fp) ((fp)->_cnt) +#define STDIO_CNT_LVALUE /**/ +#endif + +/* USE_STDIO_BASE: + * This symbol is defined if the _base field (or similar) of the + * stdio FILE structure can be used to access the stdio buffer for + * a file handle. If this is defined, then the FILE_base(fp) macro + * will also be defined and should be used to access this field. + * Also, the FILE_bufsiz(fp) macro will be defined and should be used + * to determine the number of bytes in the buffer. USE_STDIO_BASE + * will never be defined unless USE_STDIO_PTR is. + */ +/* FILE_base: + * This macro is used to access the _base field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_BASE is defined. + */ +/* FILE_bufsiz: + * This macro is used to determine the number of bytes in the I/O + * buffer pointed to by _base field (or equivalent) of the FILE + * structure pointed to its argument. This macro will always be defined + * if USE_STDIO_BASE is defined. + */ +#define USE_STDIO_BASE /**/ +#ifdef USE_STDIO_BASE +#define FILE_base(fp) ((fp)->_base) +#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) +#endif + +/* HAS_STRCHR: + * This symbol is defined to indicate that the strchr()/strrchr() + * functions are available for string searching. If not, try the + * index()/rindex() pair. + */ +/* HAS_INDEX: + * This symbol is defined to indicate that the index()/rindex() + * functions are available for string searching. + */ +#define HAS_STRCHR /**/ +/*#define HAS_INDEX /**/ + +/* HAS_STRCOLL: + * This symbol, if defined, indicates that the strcoll routine is + * available to compare strings using collating information. + */ +#define HAS_STRCOLL /**/ + +/* USE_STRUCT_COPY: + * This symbol, if defined, indicates that this C compiler knows how + * to copy structures. If undefined, you'll need to use a block copy + * routine of some sort instead. + */ +#define USE_STRUCT_COPY /**/ + +/* HAS_STRERROR: + * This symbol, if defined, indicates that the strerror routine is + * available to translate error numbers to strings. See the writeup + * of Strerror() in this file before you try to define your own. + */ +/* HAS_SYS_ERRLIST: + * This symbol, if defined, indicates that the sys_errlist array is + * available to translate error numbers to strings. The extern int + * sys_nerr gives the size of that table. + */ +/* Strerror: + * This preprocessor symbol is defined as a macro if strerror() is + * not available to translate error numbers to strings but sys_errlist[] + * array is there. + */ +#define HAS_STRERROR /**/ +#define HAS_SYS_ERRLIST /**/ +#define Strerror(e) strerror(e) + +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to provide better numeric string conversion than atof(). + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + +/* HAS_STRXFRM: + * This symbol, if defined, indicates that the strxfrm() routine is + * available to transform strings. + */ +#define HAS_STRXFRM /**/ + +/* HAS_SYMLINK: + * This symbol, if defined, indicates that the symlink routine is available + * to create symbolic links. + */ +/*#define HAS_SYMLINK /**/ + +/* HAS_SYSCALL: + * This symbol, if defined, indicates that the syscall routine is + * available to call arbitrary system calls. If undefined, that's tough. + */ +/*#define HAS_SYSCALL /**/ + +/* HAS_SYSCONF: + * This symbol, if defined, indicates that sysconf() is available + * to determine system related limits and options. + */ +/*#define HAS_SYSCONF /**/ + +/* HAS_SYSTEM: + * This symbol, if defined, indicates that the system routine is + * available to issue a shell command. + */ +#define HAS_SYSTEM /**/ + +/* HAS_TCGETPGRP: + * This symbol, if defined, indicates that the tcgetpgrp routine is + * available to get foreground process group ID. + */ +/*#define HAS_TCGETPGRP /**/ + +/* HAS_TCSETPGRP: + * This symbol, if defined, indicates that the tcsetpgrp routine is + * available to set foreground process group ID. + */ +/*#define HAS_TCSETPGRP /**/ + +/* Time_t: + * This symbol holds the type returned by time(). It can be long, + * or time_t on BSD sites (in which case <sys/types.h> should be + * included). + */ +#define Time_t time_t /* Time type */ + +/* HAS_TIMES: + * This symbol, if defined, indicates that the times() routine exists. + * Note that this became obsolete on some systems (SUNOS), which now + * use getrusage(). It may be necessary to include <sys/times.h>. + */ +#define HAS_TIMES /**/ + +/* HAS_TRUNCATE: + * This symbol, if defined, indicates that the truncate routine is + * available to truncate files. + */ +/*#define HAS_TRUNCATE /**/ + +/* HAS_TZNAME: + * This symbol, if defined, indicates that the tzname[] array is + * available to access timezone names. + */ +#define HAS_TZNAME /**/ + +/* HAS_UMASK: + * This symbol, if defined, indicates that the umask routine is + * available to set and get the value of the file creation mask. + */ +#define HAS_UMASK /**/ + +/* HAS_VFORK: + * This symbol, if defined, indicates that vfork() exists. + */ +/*#define HAS_VFORK /**/ + +/* Signal_t: + * This symbol's value is either "void" or "int", corresponding to the + * appropriate return type of a signal handler. Thus, you can declare + * a signal handler using "Signal_t (*handler)()", and define the + * handler using "Signal_t handler(sig)". + */ +#define Signal_t void /* Signal handler's return type */ + +/* HASVOLATILE: + * This symbol, if defined, indicates that this C compiler knows about + * the volatile declaration. + */ +#define HASVOLATILE /**/ +#ifndef HASVOLATILE +#define volatile +#endif + +/* HAS_VPRINTF: + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* USE_CHAR_VSPRINTF: + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +#define HAS_VPRINTF /**/ +/*#define USE_CHAR_VSPRINTF /**/ + +/* HAS_WAIT4: + * This symbol, if defined, indicates that wait4() exists. + */ +/*#define HAS_WAIT4 /**/ + +/* HAS_WAITPID: + * This symbol, if defined, indicates that the waitpid routine is + * available to wait for child process. + */ +/*#define HAS_WAITPID /**/ + +/* HAS_WCSTOMBS: + * This symbol, if defined, indicates that the wcstombs routine is + * available to convert wide character strings to multibyte strings. + */ +#define HAS_WCSTOMBS /**/ + +/* HAS_WCTOMB: + * This symbol, if defined, indicates that the wctomb routine is available + * to covert a wide character to a multibyte. + */ +#define HAS_WCTOMB /**/ + +/* Fpos_t: + * This symbol holds the type used to declare file positions in libc. + * It can be fpos_t, long, uint, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Fpos_t fpos_t /* File position type */ + +/* Gid_t: + * This symbol holds the return type of getgid() and the type of + * argument to setrgid() and related functions. Typically, + * it is the type of group ids in the kernel. It can be int, ushort, + * uid_t, etc... It may be necessary to include <sys/types.h> to get + * any typedef'ed information. + */ +#define Gid_t gid_t /* Type for getgid(), etc... */ + +/* Groups_t: + * This symbol holds the type used for the second argument to + * [gs]etgroups(). Usually, this is the same of gidtype, but + * sometimes it isn't. It can be int, ushort, uid_t, etc... + * It may be necessary to include <sys/types.h> to get any + * typedef'ed information. This is only required if you have + * getgroups() or setgroups(). + */ +#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) +#define Groups_t gid_t /* Type for 2nd arg to [gs]etgroups() */ +#endif + +/* DB_Prefix_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is u_int32_t. + */ +/* DB_Hash_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is size_t. + */ +#define DB_Hash_t int /**/ +#define DB_Prefix_t int /**/ + +/* I_DIRENT: + * This symbol, if defined, indicates to the C program that it should + * include <dirent.h>. Using this symbol also triggers the definition + * of the Direntry_t define which ends up being 'struct dirent' or + * 'struct direct' depending on the availability of <dirent.h>. + */ +/* DIRNAMLEN: + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +/* Direntry_t: + * This symbol is set to 'struct direct' or 'struct dirent' depending on + * whether dirent is available or not. You should use this pseudo type to + * portably declare your directory entries. + */ +#define I_DIRENT /**/ +#define DIRNAMLEN /**/ +#define Direntry_t struct direct + +/* I_DLFCN: + * This symbol, if defined, indicates that <dlfcn.h> exists and should + * be included. + */ +#define I_DLFCN /**/ + +/* I_FCNTL: + * This manifest constant tells the C program to include <fcntl.h>. + */ +#define I_FCNTL /**/ + +/* I_FLOAT: + * This symbol, if defined, indicates to the C program that it should + * include <float.h> to get definition of symbols like DBL_MAX or + * DBL_MIN, i.e. machine dependent floating point values. + */ +#define I_FLOAT /**/ + +/* I_GRP: + * This symbol, if defined, indicates to the C program that it should + * include <grp.h>. + */ +#define I_GRP /**/ + +/* I_LIMITS: + * This symbol, if defined, indicates to the C program that it should + * include <limits.h> to get definition of symbols like WORD_BIT or + * LONG_MAX, i.e. machine dependant limitations. + */ +#define I_LIMITS /**/ + +/* I_MATH: + * This symbol, if defined, indicates to the C program that it should + * include <math.h>. + */ +#define I_MATH /**/ + +/* I_MEMORY: + * This symbol, if defined, indicates to the C program that it should + * include <memory.h>. + */ +/*#define I_MEMORY /**/ + +/* I_NDBM: + * This symbol, if defined, indicates that <ndbm.h> exists and should + * be included. + */ +/*#define I_NDBM /**/ + +/* I_NET_ERRNO: + * This symbol, if defined, indicates that <net/errno.h> exists and + * should be included. + */ +/*#define I_NET_ERRNO /**/ + +/* I_NETINET_IN: + * This symbol, if defined, indicates to the C program that it should + * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. + */ +/*#define I_NETINET_IN /**/ + +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include <pwd.h>. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +/*#define I_PWD /**/ +/*#define PWQUOTA /**/ +/*#define PWAGE /**/ +/*#define PWCHANGE /**/ +/*#define PWCLASS /**/ +/*#define PWEXPIRE /**/ +/*#define PWCOMMENT /**/ + +/* I_STDDEF: + * This symbol, if defined, indicates that <stddef.h> exists and should + * be included. + */ +#define I_STDDEF /**/ + +/* I_STDLIB: + * This symbol, if defined, indicates that <stdlib.h> exists and should + * be included. + */ +#define I_STDLIB /**/ + +/* I_STRING: + * This symbol, if defined, indicates to the C program that it should + * include <string.h> (USG systems) instead of <strings.h> (BSD systems). + */ +#define I_STRING /**/ + +/* I_SYS_DIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/dir.h>. + */ +/*#define I_SYS_DIR /**/ + +/* I_SYS_FILE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/file.h> to get definition of R_OK and friends. + */ +/*#define I_SYS_FILE /**/ + +/* I_SYS_IOCTL: + * This symbol, if defined, indicates that <sys/ioctl.h> exists and should + * be included. Otherwise, include <sgtty.h> or <termio.h>. + */ +/*#define I_SYS_IOCTL /**/ + +/* I_SYS_NDIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/ndir.h>. + */ +/*#define I_SYS_NDIR /**/ + +/* I_SYS_PARAM: + * This symbol, if defined, indicates to the C program that it should + * include <sys/param.h>. + */ +/*#define I_SYS_PARAM /**/ + +/* I_SYS_RESOURCE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/resource.h>. + */ +/*#define I_SYS_RESOURCE /**/ + +/* I_SYS_SELECT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/select.h> in order to get definition of struct timeval. + */ +/*#define I_SYS_SELECT /**/ + +/* I_SYS_TIMES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/times.h>. + */ +/*#define I_SYS_TIMES /**/ + +/* I_SYS_TYPES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/types.h>. + */ +#define I_SYS_TYPES /**/ + +/* I_SYS_UN: + * This symbol, if defined, indicates to the C program that it should + * include <sys/un.h> to get UNIX domain socket definitions. + */ +/*#define I_SYS_UN /**/ + +/* I_SYS_WAIT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/wait.h>. + */ +/*#define I_SYS_WAIT /**/ + +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * <termio.h> rather than <sgtty.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * <sgtty.h> rather than <termio.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/*#define I_TERMIO /**/ +/*#define I_TERMIOS /**/ +/*#define I_SGTTY /**/ + +/* I_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <time.h>. + */ +/* I_SYS_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h>. + */ +/* I_SYS_TIME_KERNEL: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h> with KERNEL defined. + */ +#define I_TIME /**/ +/*#define I_SYS_TIME /**/ +/*#define I_SYS_TIME_KERNEL /**/ + +/* I_UNISTD: + * This symbol, if defined, indicates to the C program that it should + * include <unistd.h>. + */ +/*#define I_UNISTD /**/ + +/* I_UTIME: + * This symbol, if defined, indicates to the C program that it should + * include <utime.h>. + */ +#define I_UTIME /**/ + +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include <varargs.h>. + */ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +/*#define I_VFORK /**/ + +/* INTSIZE: + * This symbol contains the value of sizeof(int) so that the C + * preprocessor can make decisions based on it. + */ +/* LONGSIZE: + * This symbol contains the value of sizeof(long) so that the C + * preprocessor can make decisions based on it. + */ +/* SHORTSIZE: + * This symbol contains the value of sizeof(short) so that the C + * preprocessor can make decisions based on it. + */ +#define INTSIZE 4 /**/ +#define LONGSIZE 4 /**/ +#define SHORTSIZE 2 /**/ + +/* Off_t: + * This symbol holds the type used to declare offsets in the kernel. + * It can be int, long, off_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Off_t off_t /* <offset> type */ + +/* Mode_t: + * This symbol holds the type used to declare file modes + * for systems calls. It is usually mode_t, but may be + * int or unsigned short. It may be necessary to include <sys/types.h> + * to get any typedef'ed information. + */ +#define Mode_t mode_t /* file mode parameter for system calls */ + +/* VAL_O_NONBLOCK: + * This symbol is to be used during open() or fcntl(F_SETFL) to turn on + * non-blocking I/O for the file descriptor. Note that there is no way + * back, i.e. you cannot turn it blocking again this way. If you wish to + * alternatively switch between blocking and non-blocking, use the + * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. + */ +/* VAL_EAGAIN: + * This symbol holds the errno error code set by read() when no data was + * present on the non-blocking file descriptor. + */ +/* RD_NODATA: + * This symbol holds the return code from read() when no data is present + * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is + * not defined, then you can't distinguish between no data and EOF by + * issuing a read(). You'll have to find another way to tell for sure! + */ +/* EOF_NONBLOCK: + * This symbol, if defined, indicates to the C program that a read() on + * a non-blocking file descriptor will return 0 on EOF, and not the value + * held in RD_NODATA (-1 usually, in that case!). + */ +#define VAL_O_NONBLOCK O_NONBLOCK +#define VAL_EAGAIN EAGAIN +#define RD_NODATA -1 +#define EOF_NONBLOCK + +/* CAN_PROTOTYPE: + * If defined, this macro indicates that the C compiler can handle + * function prototypes. + */ +/* _: + * This macro is used to declare function parameters for folks who want + * to make declarations with prototypes using a different style than + * the above macros. Use double parentheses. For example: + * + * int main _((int argc, char *argv[])); + */ +#define CAN_PROTOTYPE /**/ +#ifdef CAN_PROTOTYPE +#define _(args) args +#else +#define _(args) () +#endif + +/* RANDBITS: + * This symbol contains the number of bits of random number the rand() + * function produces. Usual values are 15, 16, and 31. + */ +#define RANDBITS 15 /**/ + +/* Select_fd_set_t: + * This symbol holds the type used for the 2nd, 3rd, and 4th + * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET + * is defined, and 'int *' otherwise. This is only useful if you + * have select(), of course. + */ +#define Select_fd_set_t int * /**/ + +/* Size_t: + * This symbol holds the type used to declare length parameters + * for string functions. It is usually size_t, but may be + * unsigned long, int, etc. It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Size_t size_t /* length paramater for string functions */ + +/* SSize_t: + * This symbol holds the type used by functions that return + * a count of bytes or an error condition. It must be a signed type. + * It is usually ssize_t, but may be long or int, etc. + * It may be necessary to include <sys/types.h> or <unistd.h> + * to get any typedef'ed information. + * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). + */ +#define SSize_t int /* signed count of bytes */ + +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR unsigned char /**/ + +/* Uid_t: + * This symbol holds the type used to declare user ids in the kernel. + * It can be int, ushort, uid_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Uid_t uid_t /* UID type */ + +/* LOC_SED: + * This symbol holds the complete pathname to the sed program. + */ +#define LOC_SED "" /**/ + +/* OSNAME: + * This symbol contains the name of the operating system, as determined + * by Configure. You shouldn't rely on it too much; the specific + * feature tests from Configure are generally more reliable. + */ +#define OSNAME "MSWin32" /**/ + +/* ARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user wants to put architecture-dependent public + * library files for perl5. It is most often a local directory + * such as /usr/local/lib. Programs using this variable must be + * prepared to deal with filename expansion. If ARCHLIB is the + * same as PRIVLIB, it is not defined, since presumably the + * program already searches PRIVLIB. + */ +/* ARCHLIB_EXP: + * This symbol contains the ~name expanded version of ARCHLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define ARCHLIB "c:\\perl\\lib" /**/ +#define ARCHLIB_EXP (win32PerlLibPath()) /**/ + +/* BINCOMPAT3: + * This symbol, if defined, indicates that Perl 5.004 should be + * binary-compatible with Perl 5.003. + */ +/*#define BINCOMPAT3 /**/ + +/* BYTEORDER: + * This symbol holds the hexadecimal constant defined in byteorder, + * i.e. 0x1234 or 0x4321, etc... + * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture + * Binaries (MAB) on either big endian or little endian machines. + * The endian-ness is available at compile-time. This only matters + * for perl, where the config.h can be generated and installed on + * one system, and used by a different architecture to build an + * extension. Older versions of NeXT that might not have + * defined either *_ENDIAN__ were all on Motorola 680x0 series, + * so the default case (for NeXT) is big endian to catch them. + * This might matter for NeXT 3.0. + */ +#ifndef NeXT +#define BYTEORDER 0x1234 /* large digits for MSB */ +#else /* NeXT */ +#ifdef __LITTLE_ENDIAN__ +#define BYTEORDER 0x1234 +#else /* __BIG_ENDIAN__ */ +#define BYTEORDER 0x4321 +#endif /* ENDIAN CHECK */ +#endif /* NeXT */ + +/* CSH: + * This symbol, if defined, indicates that the C-shell exists. + * If defined, contains the full pathname of csh. + */ +/*#define CSH "" /**/ + +/* DLSYM_NEEDS_UNDERSCORE: + * This symbol, if defined, indicates that we need to prepend an + * underscore to the symbol name before calling dlsym(). This only + * makes sense if you *have* dlsym, which we will presume is the + * case if you're using dl_dlopen.xs. + */ +/*#define DLSYM_NEEDS_UNDERSCORE /**/ + +/* SETUID_SCRIPTS_ARE_SECURE_NOW: + * This symbol, if defined, indicates that the bug that prevents + * setuid scripts from being secure is not present in this kernel. + */ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +/*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +/*#define DOSUID /**/ + +/* Gconvert: + * This preprocessor macro is defined to convert a floating point + * number to a string without a trailing decimal point. This + * emulates the behavior of sprintf("%g"), but is sometimes much more + * efficient. If gconvert() is not available, but gcvt() drops the + * trailing decimal point, then gcvt() is used. If all else fails, + * a macro using sprintf("%g") is used. Arguments for the Gconvert + * macro are: value, number of digits, whether trailing zeros should + * be retained, and the output buffer. + * Possible values are: + * d_Gconvert='gconvert((x),(n),(t),(b))' + * d_Gconvert='gcvt((x),(n),(b))' + * d_Gconvert='sprintf((b),"%.*g",(n),(x))' + * The last two assume trailing zeros should not be kept. + */ +#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) + +/* HAS_GETPGID: + * This symbol, if defined, indicates to the C program that + * the getpgid(pid) function is available to get the + * process group id. + */ +/*#define HAS_GETPGID /**/ + +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +/*#define HAS_GETPGRP /**/ +/*#define USE_BSD_GETPGRP /**/ + +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +/*#define HAS_INET_ATON /**/ + +/* HAS_SETPGID: + * This symbol, if defined, indicates to the C program that + * the setpgid(pid, gpid) function is available to set the + * process group id. + */ +/*#define HAS_SETPGID /**/ + +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +/* USE_BSDPGRP: + * This symbol, if defined, indicates that the BSD notion of process + * group is to be used. For instance, you have to say setpgrp(pid, pgrp) + * instead of the USG setpgrp(). This should be obsolete since + * there are systems which have BSD-ish setpgrp but USG-ish getpgrp. + */ +/*#define HAS_SETPGRP /**/ +/*#define USE_BSD_SETPGRP /**/ +/*#define USE_BSDPGRP /**/ + +/* USE_SFIO: + * This symbol, if defined, indicates that sfio should + * be used. + */ +/*#define USE_SFIO /**/ + +/* Sigjmp_buf: + * This is the buffer type to be used with Sigsetjmp and Siglongjmp. + */ +/* Sigsetjmp: + * This macro is used in the same way as sigsetjmp(), but will invoke + * traditional setjmp() if sigsetjmp isn't available. + * See HAS_SIGSETJMP. + */ +/* Siglongjmp: + * This macro is used in the same way as siglongjmp(), but will invoke + * traditional longjmp() if siglongjmp isn't available. + * See HAS_SIGSETJMP. + */ +/*#define HAS_SIGSETJMP /**/ +#ifdef HAS_SIGSETJMP +#define Sigjmp_buf sigjmp_buf +#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) +#define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) +#else +#define Sigjmp_buf jmp_buf +#define Sigsetjmp(buf,save_mask) setjmp((buf)) +#define Siglongjmp(buf,retval) longjmp((buf),(retval)) +#endif + +/* USE_DYNAMIC_LOADING: + * This symbol, if defined, indicates that dynamic loading of + * some sort is available. + */ +#define USE_DYNAMIC_LOADING /**/ + +/* I_DBM: + * This symbol, if defined, indicates that <dbm.h> exists and should + * be included. + */ +/* I_RPCSVC_DBM: + * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and + * should be included. + */ +/*#define I_DBM /**/ +#define I_RPCSVC_DBM /**/ + +/* I_LOCALE: + * This symbol, if defined, indicates to the C program that it should + * include <locale.h>. + */ +#define I_LOCALE /**/ + +/* I_SFIO: + * This symbol, if defined, indicates to the C program that it should + * include <sfio.h>. + */ +/*#define I_SFIO /**/ + +/* I_SYS_STAT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/stat.h>. + */ +#define I_SYS_STAT /**/ + +/* I_VALUES: + * This symbol, if defined, indicates to the C program that it should + * include <values.h> to get definition of symbols like MINFLOAT or + * MAXLONG, i.e. machine dependant limitations. Probably, you + * should use <limits.h> instead, if it is available. + */ +/*#define I_VALUES /**/ + +/* Free_t: + * This variable contains the return type of free(). It is usually + * void, but occasionally int. + */ +/* Malloc_t: + * This symbol is the type of pointer returned by malloc and realloc. + */ +#define Malloc_t void * /**/ +#define Free_t void /**/ + +/* MYMALLOC: + * This symbol, if defined, indicates that we're using our own malloc. + */ +/*#define MYMALLOC /**/ + +/* OLDARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user has perl5.000 or perl5.001 architecture-dependent + * public library files for perl5. For the most part, these + * files will work with 5.002 (and later), but that is not + * guaranteed. + */ +/* OLDARCHLIB_EXP: + * This symbol contains the ~name expanded version of OLDARCHLIB, to be + * used in programs that are not prepared to deal with ~ expansion at + * run-time. + */ +/*#define OLDARCHLIB "" /**/ +/*#define OLDARCHLIB_EXP "" /**/ + +/* PRIVLIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + */ +/* PRIVLIB_EXP: + * This symbol contains the ~name expanded version of PRIVLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define PRIVLIB "c:\\perl\\lib" /**/ +#define PRIVLIB_EXP "c:\\perl\\lib" /**/ + +/* SH_PATH: + * This symbol contains the full pathname to the shell used on this + * on this system to execute Bourne shell scripts. Usually, this will be + * /bin/sh, though it's possible that some systems will have /bin/ksh, + * /bin/pdksh, /bin/ash, /bin/bash, or even something such as + * D:/bin/sh.exe. + */ +#define SH_PATH "cmd.exe" /**/ + +/* SIG_NAME: + * This symbol contains a list of signal names in order of + * signal number. This is intended + * to be used as a static array initialization, like this: + * char *sig_name[] = { SIG_NAME }; + * The signals in the list are separated with commas, and each signal + * is surrounded by double quotes. There is no leading SIG in the signal + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). + * The signal number for sig_name[i] is stored in sig_num[i]. + * The last element is 0 to terminate the list with a NULL. This + * corresponds to the 0 at the end of the sig_num list. + */ +/* SIG_NUM: + * This symbol contains a list of signal numbers, in the same order as the + * SIG_NAME list. It is suitable for static array initialization, as in: + * int sig_num[] = { SIG_NUM }; + * The signals in the list are separated with commas, and the indices + * within that list and the SIG_NAME list match, so it's easy to compute + * the signal name from a number or vice versa at the price of a small + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name list. + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CHLD","PWR","WINCH","URG","IO","STOP","TSTP","CONT","TTIN","TTOU","VTALRM","PROF","XCPU","XFSZ","WAITING","LWP","FREEZE","THAW","RTMIN","NUM37","NUM38","NUM39","NUM40","NUM41","NUM42","RTMAX","IOT","CLD","POLL",0 /**/ +#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,6,18,22,0 /**/ + +/* SITEARCH: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * Individual sites may place their own extensions and modules in + * this directory. + */ +/* SITEARCH_EXP: + * This symbol contains the ~name expanded version of SITEARCH, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define SITEARCH "c:\\perl\\lib\\site" /**/ +#define SITEARCH_EXP "c:\\perl\\lib\\site" /**/ + +/* SITELIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * Individual sites may place their own extensions and modules in + * this directory. + */ +/* SITELIB_EXP: + * This symbol contains the ~name expanded version of SITELIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define SITELIB "c:\\perl\\lib\\site" /**/ +#define SITELIB_EXP "c:\\perl\\lib\\site" /**/ + +/* STARTPERL: + * This variable contains the string to put in front of a perl + * script to make sure (one hopes) that it runs with perl and not + * some shell. + */ +#define STARTPERL "#perl" /**/ + +/* USE_PERLIO: + * This symbol, if defined, indicates that the PerlIO abstraction should + * be used throughout. If not defined, stdio should be + * used in a fully backward compatible manner. + */ +/*#define USE_PERLIO /**/ + +/* VOIDFLAGS: + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * 8 = suports declaration of generic void pointers + * + * The package designer should define VOIDUSED to indicate the requirements + * of the package. This can be done either by #defining VOIDUSED before + * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the + * level of void support necessary is not present, defines void to int. + */ +#ifndef VOIDUSED +#define VOIDUSED 15 +#endif +#define VOIDFLAGS 15 +#if (VOIDFLAGS & VOIDUSED) != VOIDUSED +#define void int /* is void to be avoided? */ +#define M_VOID /* Xenix strikes again */ +#endif + +#endif +#include <win32.h> +#ifndef DEBUGGING +#define DEBUGGING +#endif diff --git a/gnu/usr.bin/perl/win32/config_h.PL b/gnu/usr.bin/perl/win32/config_h.PL new file mode 100644 index 00000000000..5d47016dc97 --- /dev/null +++ b/gnu/usr.bin/perl/win32/config_h.PL @@ -0,0 +1,92 @@ +# +use Config; +use File::Compare qw(compare); +use File::Copy qw(copy); +my $name = $0; +$name =~ s#^(.*)\.PL$#../$1.SH#; +open(SH,"<$name") || die "Cannot open $name:$!"; +while (<SH>) + { + last if /^sed/; + } +($term,$file,$pat) = /^sed\s+<<(\S+)\s+>(\S+)\s+(.*)$/; + +my $str = "sub munge\n{\n"; + +while ($pat =~ s/-e\s+'([^']*)'\s*//) + { + my $e = $1; + $e =~ s/\\([\(\)])/$1/g; + $e =~ s/\\(\d)/\$$1/g; + $str .= "$e;\n"; + } +$str .= "}\n"; + +eval $str; + +die "$str:$@" if $@; + +open(H,">$file.new") || die "Cannot open $file.new:$!"; +while (<SH>) + { + last if /^$term$/o; + s/\$([\w_]+)/Config($1)/eg; + s/`([^\`]*)`/BackTick($1)/eg; + munge(); + s/\\\$/\$/g; + s#/[ *\*]*\*/#/**/#; + if (/^\s*#define\s+ARCHLIB_EXP/) + { + $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n" + . "#define APPLLIB_EXP (win32SiteLibPath())\t/**/\n"; + } + print H; + } +print H "#include <win32.h> +#ifndef DEBUGGING +#define DEBUGGING +#endif +"; +close(H); +close(SH); + + +chmod(0666,"../lib/CORE/config.h"); +copy("$file.new","../lib/CORE/config.h") || die "Cannot copy:$!"; +chmod(0444,"../lib/CORE/config.h"); + +if (compare("$file.new",$file)) + { + warn "$file has changed\n"; + chmod(0666,$file); + unlink($file); + rename("$file.new",$file); + chmod(0444,$file); + exit(1); + } + +sub Config +{ + my $var = shift; + my $val = $Config{$var}; + $val = 'undef' unless defined $val; + $val =~ s/\\/\\\\/g; + return $val; +} + +sub BackTick +{ + my $cmd = shift; + if ($cmd =~ /^echo\s+(.*?)\s*\|\s+sed\s+'(.*)'\s*$/) + { + local ($data,$pat) = ($1,$2); + $data =~ s/\s+/ /g; + eval "\$data =~ $pat"; + return $data; + } + else + { + die "Cannot handle \`$cmd\`"; + } + return $cmd; +} diff --git a/gnu/usr.bin/perl/win32/config_sh.PL b/gnu/usr.bin/perl/win32/config_sh.PL new file mode 100644 index 00000000000..0769ef31120 --- /dev/null +++ b/gnu/usr.bin/perl/win32/config_sh.PL @@ -0,0 +1,23 @@ +my %opt; +while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) + { + $opt{$1}=$2; + shift(@ARGV); + } + +if ($] =~ /\.(\d\d\d)?(\d\d)?$/) { # should always be true + $opt{PATCHLEVEL} = int($1 || 0); + $opt{SUBVERSION} = $2 || '00'; +} + +$opt{'cf_by'} = $ENV{USERNAME} unless $opt{'cf_by'}; +$opt{'cf_email'} = $opt{'cf_by'} . '@' . (gethostbyname('localhost'))[0] + unless $opt{'cf_email'}; + +while (<>) + { + s/~([\w_]+)~/$opt{$1}/g; + $_ = "$1='$opt{$1}'\n" if (/^([\w_]+)=/ && exists($opt{$1})); + print; + } + diff --git a/gnu/usr.bin/perl/win32/dl_win32.xs b/gnu/usr.bin/perl/win32/dl_win32.xs new file mode 100644 index 00000000000..7b227e299c9 --- /dev/null +++ b/gnu/usr.bin/perl/win32/dl_win32.xs @@ -0,0 +1,112 @@ +/* dl_win32.xs + * + * Platform: Win32 (Windows NT/Windows 95) + * Author: Wei-Yuen Tan (wyt@hip.com) + * Created: A warm day in June, 1995 + * + * Modified: + * August 23rd 1995 - rewritten after losing everything when I + * wiped off my NT partition (eek!) + */ + +/* Porting notes: + +I merely took Paul's dl_dlopen.xs, took out extraneous stuff and +replaced the appropriate SunOS calls with the corresponding Win32 +calls. + +*/ + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#include <string.h> + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* SaveError() etc */ + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +static int +dl_static_linked(char *filename) +{ + char **p; + for (p = staticlinkmodules; *p;p++) { + if (strstr(filename, *p)) return 1; + }; + return 0; +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void * +dl_load_file(filename,flags=0) + char * filename + int flags + PREINIT: + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + if (dl_static_linked(filename) == 0) + RETVAL = (void*) LoadLibraryEx(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; + else + RETVAL = (void*) GetModuleHandle(NULL); + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%d",GetLastError()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%d",GetLastError()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CV*))symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/gnu/usr.bin/perl/win32/genxsdef.pl b/gnu/usr.bin/perl/win32/genxsdef.pl new file mode 100644 index 00000000000..b00a57e7787 --- /dev/null +++ b/gnu/usr.bin/perl/win32/genxsdef.pl @@ -0,0 +1,5 @@ +print "LIBRARY $ARGV[0]\n"; +print "CODE LOADONCALL\n"; +print "DATA LOADONCALL NONSHARED MULTIPLE\n"; +print "EXPORTS\n"; +print "\tboot_$ARGV[0]\n" diff --git a/gnu/usr.bin/perl/win32/include/arpa/inet.h b/gnu/usr.bin/perl/win32/include/arpa/inet.h new file mode 100644 index 00000000000..0303df0876b --- /dev/null +++ b/gnu/usr.bin/perl/win32/include/arpa/inet.h @@ -0,0 +1,4 @@ +/* + * this is a dummy header file for Socket.xs + */ + diff --git a/gnu/usr.bin/perl/win32/include/dirent.h b/gnu/usr.bin/perl/win32/include/dirent.h new file mode 100644 index 00000000000..8cc7e11479b --- /dev/null +++ b/gnu/usr.bin/perl/win32/include/dirent.h @@ -0,0 +1,49 @@ +// dirent.h + +// djl +// Provide UNIX compatibility + +#ifndef _INC_DIRENT +#define _INC_DIRENT + +// +// NT versions of readdir(), etc +// From the MSDOS implementation +// + +// Directory entry size +#ifdef DIRSIZ +#undef DIRSIZ +#endif +#define DIRSIZ(rp) (sizeof(struct direct)) + +// needed to compile directory stuff +#define DIRENT direct + +// structure of a directory entry +typedef struct direct +{ + long d_ino; // inode number (not used by MS-DOS) + int d_namlen; // Name length + char d_name[257]; // file name +} _DIRECT; + +// structure for dir operations +typedef struct _dir_struc +{ + char *start; // Starting position + char *curr; // Current position + long size; // Size of string table + long nfiles; // number if filenames in table + struct direct dirstr; // Directory structure to return +} DIR; + +DIR *opendir(char *filename); +struct direct *readdir(DIR *dirp); +long telldir(DIR *dirp); +void seekdir(DIR *dirp,long loc); +void rewinddir(DIR *dirp); +int closedir(DIR *dirp); + + +#endif //_INC_DIRENT diff --git a/gnu/usr.bin/perl/win32/include/netdb.h b/gnu/usr.bin/perl/win32/include/netdb.h new file mode 100644 index 00000000000..b0c5ea1949d --- /dev/null +++ b/gnu/usr.bin/perl/win32/include/netdb.h @@ -0,0 +1,12 @@ +// netdb.h + +// djl +// Provide UNIX compatibility + + +#ifndef _INC_NETDB +#define _INC_NETDB + +#include <sys/socket.h> + +#endif //_INC_NETDB diff --git a/gnu/usr.bin/perl/win32/include/sys/socket.h b/gnu/usr.bin/perl/win32/include/sys/socket.h new file mode 100644 index 00000000000..9e5259b254f --- /dev/null +++ b/gnu/usr.bin/perl/win32/include/sys/socket.h @@ -0,0 +1,149 @@ +// sys/socket.h + +// djl +// Provide UNIX compatibility + +#ifndef _INC_SYS_SOCKET +#define _INC_SYS_SOCKET + +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef _WINDOWS_ +#define _WINDOWS_ + +#define FAR +#define PASCAL __stdcall +#define WINAPI __stdcall + +#undef WORD +typedef int BOOL; +typedef unsigned short WORD; +typedef void* HANDLE; +typedef void* HWND; +typedef int (FAR WINAPI *FARPROC)(); + +typedef unsigned long DWORD; +typedef void *PVOID; + +#define IN +#define OUT + +typedef struct _OVERLAPPED { + DWORD Internal; + DWORD InternalHigh; + DWORD Offset; + DWORD OffsetHigh; + HANDLE hEvent; +} OVERLAPPED, *LPOVERLAPPED; + +#endif //_WINDOWS_ +#include <winsock.h> + +#define ENOTSOCK WSAENOTSOCK +#undef HOST_NOT_FOUND + + +SOCKET win32_accept (SOCKET s, struct sockaddr *addr, int *addrlen); +int win32_bind (SOCKET s, const struct sockaddr *addr, int namelen); +int win32_closesocket (SOCKET s); +int win32_connect (SOCKET s, const struct sockaddr *name, int namelen); +int win32_ioctlsocket (SOCKET s, long cmd, u_long *argp); +int win32_getpeername (SOCKET s, struct sockaddr *name, int * namelen); +int win32_getsockname (SOCKET s, struct sockaddr *name, int * namelen); +int win32_getsockopt (SOCKET s, int level, int optname, char * optval, int *optlen); +u_long win32_htonl (u_long hostlong); +u_short win32_htons (u_short hostshort); +unsigned long win32_inet_addr (const char * cp); +char * win32_inet_ntoa (struct in_addr in); +int win32_listen (SOCKET s, int backlog); +u_long win32_ntohl (u_long netlong); +u_short win32_ntohs (u_short netshort); +int win32_recv (SOCKET s, char * buf, int len, int flags); +int win32_recvfrom (SOCKET s, char * buf, int len, int flags, + struct sockaddr *from, int * fromlen); +int win32_select (int nfds, int *readfds, int *writefds, int *exceptfds, const struct timeval *timeout); +int win32_send (SOCKET s, const char * buf, int len, int flags); +int win32_sendto (SOCKET s, const char * buf, int len, int flags, + const struct sockaddr *to, int tolen); +int win32_setsockopt (SOCKET s, int level, int optname, + const char * optval, int optlen); +SOCKET win32_socket (int af, int type, int protocol); +int win32_shutdown (SOCKET s, int how); + +/* Database function prototypes */ + +struct hostent * win32_gethostbyaddr(const char * addr, int len, int type); +struct hostent * win32_gethostbyname(const char * name); +int win32_gethostname (char * name, int namelen); +struct servent * win32_getservbyport(int port, const char * proto); +struct servent * win32_getservbyname(const char * name, const char * proto); +struct protoent * win32_getprotobynumber(int proto); +struct protoent * win32_getprotobyname(const char * name); +struct protoent *win32_getprotoent(void); +struct servent *win32_getservent(void); +void win32_sethostent(int stayopen); +void win32_setnetent(int stayopen); +struct netent * win32_getnetent(void); +struct netent * win32_getnetbyname(char *name); +struct netent * win32_getnetbyaddr(long net, int type); +void win32_setprotoent(int stayopen); +void win32_setservent(int stayopen); +void win32_endhostent(void); +void win32_endnetent(void); +void win32_endprotoent(void); +void win32_endservent(void); + +// +// direct to our version +// +#define htonl win32_htonl +#define htons win32_htons +#define ntohl win32_ntohl +#define ntohs win32_ntohs +#define inet_addr win32_inet_addr +#define inet_ntoa win32_inet_ntoa + +#define socket win32_socket +#define bind win32_bind +#define listen win32_listen +#define accept win32_accept +#define connect win32_connect +#define send win32_send +#define sendto win32_sendto +#define recv win32_recv +#define recvfrom win32_recvfrom +#define shutdown win32_shutdown +#define ioctlsocket win32_ioctlsocket +#define setsockopt win32_setsockopt +#define getsockopt win32_getsockopt +#define getpeername win32_getpeername +#define getsockname win32_getsockname +#define gethostname win32_gethostname +#define gethostbyname win32_gethostbyname +#define gethostbyaddr win32_gethostbyaddr +#define getprotobyname win32_getprotobyname +#define getprotobynumber win32_getprotobynumber +#define getservbyname win32_getservbyname +#define getservbyport win32_getservbyport +#define select win32_select +#define endhostent win32_endhostent +#define endnetent win32_endnetent +#define endprotoent win32_endprotoent +#define endservent win32_endservent +#define getnetent win32_getnetent +#define getnetbyname win32_getnetbyname +#define getnetbyaddr win32_getnetbyaddr +#define getprotoent win32_getprotoent +#define getservent win32_getservent +#define sethostent win32_sethostent +#define setnetent win32_setnetent +#define setprotoent win32_setprotoent +#define setservent win32_setservent + +#ifdef __cplusplus +} +#endif + +#endif // _INC_SYS_SOCKET diff --git a/gnu/usr.bin/perl/win32/makedef.pl b/gnu/usr.bin/perl/win32/makedef.pl new file mode 100644 index 00000000000..b4883ccb593 --- /dev/null +++ b/gnu/usr.bin/perl/win32/makedef.pl @@ -0,0 +1,347 @@ +#!../miniperl + +# Written: 10 April 1996 Gary Ng (71564.1743@compuserve.com) + +# Create the export list for perl. +# Needed by WIN32 for creating perl.dll +# based on perl_exp.SH in the main perl distribution directory + +# This simple program relys on 'global.sym' being up to date +# with all of the global symbols that a dynamicly link library +# might want to access. + +# There is some symbol defined in global.sym and interp.sym +# that does not present in the WIN32 port but there is no easy +# way to find them so I just put a exception list here + +my $CCTYPE = shift || "MSVC"; + +$skip_sym=<<'!END!OF!SKIP!'; +Perl_SvIV +Perl_SvNV +Perl_SvTRUE +Perl_SvUV +Perl_block_type +Perl_sv_pvn +Perl_additem +Perl_cast_ulong +Perl_check_uni +Perl_checkcomma +Perl_chsize +Perl_ck_aelem +Perl_cryptseen +Perl_cx_dump +Perl_deb +Perl_deb_growlevel +Perl_debop +Perl_debprofdump +Perl_debstack +Perl_debstackptrs +Perl_do_ipcctl +Perl_do_ipcget +Perl_do_msgrcv +Perl_do_msgsnd +Perl_do_semop +Perl_do_shmio +Perl_doeval +Perl_dofindlabel +Perl_dopoptoeval +Perl_dump_eval +Perl_dump_fds +Perl_dump_form +Perl_dump_gv +Perl_dump_mstats +Perl_dump_op +Perl_dump_packsubs +Perl_dump_pm +Perl_dump_sub +Perl_expectterm +Perl_fetch_gv +Perl_fetch_io +Perl_force_ident +Perl_force_next +Perl_force_word +Perl_hv_stashpv +Perl_intuit_more +Perl_know_next +Perl_modkids +Perl_mstats +Perl_my_bzero +Perl_my_htonl +Perl_my_ntohl +Perl_my_swap +Perl_my_chsize +Perl_newXSUB +Perl_no_fh_allowed +Perl_no_op +Perl_nointrp +Perl_nomem +Perl_pp_cswitch +Perl_pp_entersubr +Perl_pp_evalonce +Perl_pp_interp +Perl_pp_map +Perl_pp_nswitch +Perl_q +Perl_reall_srchlen +Perl_regdump +Perl_regfold +Perl_regmyendp +Perl_regmyp_size +Perl_regmystartp +Perl_regnarrate +Perl_regprop +Perl_same_dirent +Perl_saw_return +Perl_scan_const +Perl_scan_formline +Perl_scan_heredoc +Perl_scan_ident +Perl_scan_inputsymbol +Perl_scan_pat +Perl_scan_prefix +Perl_scan_str +Perl_scan_subst +Perl_scan_trans +Perl_scan_word +Perl_setenv_getix +Perl_skipspace +Perl_sublex_done +Perl_sublex_start +Perl_sv_peek +Perl_sv_ref +Perl_sv_setptrobj +Perl_timesbuf +Perl_too_few_arguments +Perl_too_many_arguments +Perl_unlnk +Perl_wait4pid +Perl_watch +Perl_yyname +Perl_yyrule +allgvs +curblock +curcsv +lastretstr +mystack_mark +perl_init_ext +perl_requirepv +stack +statusvalue_vms +Perl_safexcalloc +Perl_safexmalloc +Perl_safexfree +Perl_safexrealloc +Perl_my_memcmp +Perl_my_memset +Perl_cshlen +Perl_cshname +!END!OF!SKIP! + +# All symbols have a Perl_ prefix because that's what embed.h +# sticks in front of them. + + +print "LIBRARY Perl\n"; +print "DESCRIPTION 'Perl interpreter, export autogenerated'\n"; +print "CODE LOADONCALL\n"; +print "DATA LOADONCALL NONSHARED MULTIPLE\n"; +print "EXPORTS\n"; + +open (GLOBAL, "<../global.sym") || die "failed to open global.sym" . $!; +while (<GLOBAL>) { + my $symbol; + next if (!/^[A-Za-z]/); + next if (/_amg[ \t]*$/); + $symbol = "Perl_$_"; + next if ($skip_sym =~ m/$symbol/m); + emit_symbol($symbol); +} +close(GLOBAL); + +# also add symbols from interp.sym +# They are only needed if -DMULTIPLICITY is not set but it +# doesn't hurt to include them anyway. +# these don't have Perl prefix + +open (INTERP, "<../interp.sym") || die "failed to open interp.sym" . $!; +while (<INTERP>) { + my $symbol; + next if (!/^[A-Za-z]/); + next if (/_amg[ \t]*$/); + $symbol = $_; + next if ($skip_sym =~ m/$symbol/m); + #print "\t$symbol"; + emit_symbol("Perl_" . $symbol); +} + +#close(INTERP); + +while (<DATA>) { + my $symbol; + next if (!/^[A-Za-z]/); + next if (/^#/); + $symbol = $_; + next if ($skip_sym =~ m/^$symbol/m); + emit_symbol($symbol); +} + +sub emit_symbol { + my $symbol = shift; + chomp $symbol; + if ($CCTYPE eq "BORLAND") { + # workaround Borland quirk by exporting both the straight + # name and a name with leading underscore. Note the + # alias *must* come after the symbol itself, if both + # are to be exported. (Linker bug?) + print "\t_$symbol\n"; + print "\t$symbol = _$symbol\n"; + } + else { + # for binary coexistence, export both the symbol and + # alias with leading underscore + print "\t$symbol\n"; + print "\t_$symbol = $symbol\n"; + } +} + +1; +__DATA__ +# extra globals not included above. +perl_init_i18nl10n +perl_init_ext +perl_alloc +perl_construct +perl_destruct +perl_free +perl_parse +perl_run +perl_get_sv +perl_get_av +perl_get_hv +perl_get_cv +perl_call_argv +perl_call_pv +perl_call_method +perl_call_sv +perl_require_pv +perl_eval_pv +perl_eval_sv +boot_DynaLoader +win32_errno +win32_environ +win32_stdin +win32_stdout +win32_stderr +win32_ferror +win32_feof +win32_strerror +win32_fprintf +win32_printf +win32_vfprintf +win32_vprintf +win32_fread +win32_fwrite +win32_fopen +win32_fdopen +win32_freopen +win32_fclose +win32_fputs +win32_fputc +win32_ungetc +win32_getc +win32_fileno +win32_clearerr +win32_fflush +win32_ftell +win32_fseek +win32_fgetpos +win32_fsetpos +win32_rewind +win32_tmpfile +win32_abort +win32_fstat +win32_stat +win32_pipe +win32_popen +win32_pclose +win32_setmode +win32_lseek +win32_tell +win32_dup +win32_dup2 +win32_open +win32_close +win32_eof +win32_read +win32_write +win32_spawnvp +win32_mkdir +win32_rmdir +win32_chdir +win32_flock +win32_execvp +win32_htons +win32_ntohs +win32_htonl +win32_ntohl +win32_inet_addr +win32_inet_ntoa +win32_socket +win32_bind +win32_listen +win32_accept +win32_connect +win32_send +win32_sendto +win32_recv +win32_recvfrom +win32_shutdown +win32_ioctlsocket +win32_setsockopt +win32_getsockopt +win32_getpeername +win32_getsockname +win32_gethostname +win32_gethostbyname +win32_gethostbyaddr +win32_getprotobyname +win32_getprotobynumber +win32_getservbyname +win32_getservbyport +win32_select +win32_endhostent +win32_endnetent +win32_endprotoent +win32_endservent +win32_getnetent +win32_getnetbyname +win32_getnetbyaddr +win32_getprotoent +win32_getservent +win32_sethostent +win32_setnetent +win32_setprotoent +win32_setservent +win32_getenv +win32_perror +win32_setbuf +win32_setvbuf +win32_flushall +win32_fcloseall +win32_fgets +win32_gets +win32_fgetc +win32_putc +win32_puts +win32_getchar +win32_putchar +win32_malloc +win32_calloc +win32_realloc +win32_free +win32stdio +Perl_win32_init +RunPerl +SetIOSubSystem +GetIOSubSystem diff --git a/gnu/usr.bin/perl/win32/makefile.mk b/gnu/usr.bin/perl/win32/makefile.mk new file mode 100644 index 00000000000..dbac98f7ffd --- /dev/null +++ b/gnu/usr.bin/perl/win32/makefile.mk @@ -0,0 +1,607 @@ +# +# Makefile to build perl on Windowns NT using Microsoft NMAKE. +# +# +# This is set up to build a perl.exe that runs off a shared library +# (perl.dll). Also makes individual DLLs for the XS extensions. +# + +# +# Set these to wherever you want "nmake install" to put your +# newly built perl. +INST_DRV=c: +INST_TOP=$(INST_DRV)\perl + +# +# uncomment one if you are using Visual C++ 2.x or Borland +# comment out both if you are using Visual C++ 4.x and above +#CCTYPE=MSVC20 +CCTYPE=BORLAND + +# +# uncomment next line if you want debug version of perl (big,slow) +#CFG=Debug + +# +# set the install locations of the compiler include/libraries +#CCHOME = f:\msdev\vc +CCHOME = D:\bc5 +CCINCDIR = $(CCHOME)\include +CCLIBDIR = $(CCHOME)\lib + +# +# set this to point to cmd.exe (only needed if you use some +# alternate shell that doesn't grok cmd.exe style commands) +SHELL = g:\winnt\system32\cmd.exe + +# +# set this to your email address (perl will guess a value from +# from your loginname and your hostname, which may not be right) +#EMAIL = + +##################### CHANGE THESE ONLY IF YOU MUST ##################### + +# +# Programs to compile, build .lib files and link +# + +.USESHELL : + +.IF "$(CCTYPE)" == "BORLAND" + +CC = bcc32 +LINK32 = tlink32 +LIB32 = tlib +IMPLIB = implib + +# +# Options +# +RUNTIME = -D_RTLDLL +INCLUDES = -I.\include -I. -I.. -I$(CCINCDIR) +#PCHFLAGS = -H -H$(INTDIR)\bcmoduls.pch +DEFINES = -DWIN32 -DPERLDLL +SUBSYS = console +LIBC = cw32mti.lib +LIBFILES = import32.lib $(LIBC) odbc32.lib odbccp32.lib + +WINIOMAYBE = + +.IF "$(CFG)" == "Debug" +OPTIMIZE = -v $(RUNTIME) +LINK_DBG = -v +.ELSE +OPTIMIZE = -O $(RUNTIME) +LINK_DBG = +.ENDIF + +CFLAGS = -w -tWM -tWD $(INCLUDES) $(DEFINES) $(PCHFLAGS) $(OPTIMIZE) +LINK_FLAGS = $(LINK_DBG) -L$(CCLIBDIR) +OBJOUT_FLAG = -o + +.ELSE + +CC=cl.exe +LINK32=link.exe +LIB32=$(LINK32) -lib +# +# Options +# +.IF "$(RUNTIME)" == "" +RUNTIME = -MD +.ENDIF +INCLUDES = -I.\include -I. -I.. +#PCHFLAGS = -Fp$(INTDIR)\vcmoduls.pch -YX +DEFINES = -DWIN32 -D_CONSOLE -DPERLDLL +SUBSYS = console + +.IF "$(RUNTIME)" == "-MD" +LIBC = msvcrt.lib +WINIOMAYBE = +.ELSE +LIBC = libcmt.lib +WINIOMAYBE = win32io.obj +.ENDIF + +.IF "$(CFG)" == "Debug" +.IF "$(CCTYPE)" == "MSVC20" +OPTIMIZE = -Od $(RUNTIME) -Z7 -D_DEBUG +.ELSE +OPTIMIZE = -Od $(RUNTIME)d -Z7 -D_DEBUG +.ENDIF +LINK_DBG = -debug -pdb:none +.ELSE +.IF "$(CCTYPE)" == "MSVC20" +OPTIMIZE = -Od $(RUNTIME) -DNDEBUG +.ELSE +OPTIMIZE = -Od $(RUNTIME) -DNDEBUG +.ENDIF +LINK_DBG = -release +.ENDIF + +# we don't add LIBC here, the compiler do it based on -MD/-MT +LIBFILES = oldnames.lib kernel32.lib user32.lib gdi32.lib \ + winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \ + oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \ + version.lib odbc32.lib odbccp32.lib + +CFLAGS = -nologo -W3 $(INCLUDES) $(DEFINES) $(PCHFLAGS) $(OPTIMIZE) +LINK_FLAGS = -nologo $(LIBFILES) $(LINK_DBG) -machine:I386 +OBJOUT_FLAG = -Fo + +.ENDIF + +#################### do not edit below this line ####################### +############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ############## + +# +# Rules +# +.SUFFIXES : +.SUFFIXES : .c .obj .dll .lib .exe + +.c.obj: + $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $< + +.IF "$(CCTYPE)" == "BORLAND" + +.obj.dll: + $(LINK32) -Tpd -ap $(LINK_FLAGS) c0d32.obj $<,$@,,$(LIBFILES),$(*B).def + $(IMPLIB) $(*B).lib $@ +.ELSE + +.obj.dll: + $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ + -out:$@ $(LINK_FLAGS) $< $(LIBPERL) + +.ENDIF + +# +INST_BIN=$(INST_TOP)\bin +INST_LIB=$(INST_TOP)\lib +INST_POD=$(INST_LIB)\pod +INST_HTML=$(INST_POD)\html +LIBDIR=..\lib +EXTDIR=..\ext +PODDIR=..\pod +EXTUTILSDIR=$(LIBDIR)\extutils + +# +# various targets +PERLIMPLIB=..\perl.lib +MINIPERL=..\miniperl.exe +PERLDLL=..\perl.dll +PERLEXE=..\perl.exe +GLOBEXE=..\perlglob.exe +CONFIGPM=..\lib\Config.pm +MINIMOD=..\lib\ExtUtils\Miniperl.pm + +PL2BAT=bin\pl2bat.pl +GLOBBAT = bin\perlglob.bat + +.IF "$(CCTYPE)" == "BORLAND" + +# Borland wildargs is incompatible with MS setargv +CFGSH_TMPL = config.bc +CFGH_TMPL = config_H.bc +# Borland's perl.exe will work on W95, so we don't make this + +.ELSE + +MAKE = nmake -nologo +CFGSH_TMPL = config.vc +CFGH_TMPL = config_H.vc +PERL95EXE=..\perl95.exe + +.ENDIF + +XCOPY=xcopy /f /r /i /d +RCOPY=xcopy /f /r /i /e /d +#NULL= + +# +# filenames given to xsubpp must have forward slashes (since it puts +# full pathnames in #line strings) +XSUBPP=..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp -C++ -prototypes + +CORE_C= ..\av.c \ + ..\deb.c \ + ..\doio.c \ + ..\doop.c \ + ..\dump.c \ + ..\globals.c \ + ..\gv.c \ + ..\hv.c \ + ..\mg.c \ + ..\op.c \ + ..\perl.c \ + ..\perlio.c \ + ..\perly.c \ + ..\pp.c \ + ..\pp_ctl.c \ + ..\pp_hot.c \ + ..\pp_sys.c \ + ..\regcomp.c \ + ..\regexec.c \ + ..\run.c \ + ..\scope.c \ + ..\sv.c \ + ..\taint.c \ + ..\toke.c \ + ..\universal.c \ + ..\util.c + +CORE_OBJ= ..\av.obj \ + ..\deb.obj \ + ..\doio.obj \ + ..\doop.obj \ + ..\dump.obj \ + ..\globals.obj \ + ..\gv.obj \ + ..\hv.obj \ + ..\mg.obj \ + ..\op.obj \ + ..\perl.obj \ + ..\perlio.obj \ + ..\perly.obj \ + ..\pp.obj \ + ..\pp_ctl.obj \ + ..\pp_hot.obj \ + ..\pp_sys.obj \ + ..\regcomp.obj \ + ..\regexec.obj \ + ..\run.obj \ + ..\scope.obj \ + ..\sv.obj \ + ..\taint.obj \ + ..\toke.obj \ + ..\universal.obj\ + ..\util.obj + +WIN32_C = perllib.c \ + win32.c \ + win32io.c \ + win32sck.c + +WIN32_OBJ = win32.obj \ + win32io.obj \ + win32sck.obj + +PERL95_OBJ = perl95.obj \ + win32mt.obj \ + win32iomt.obj \ + win32sckmt.obj + +DLL_OBJ = perllib.obj $(DYNALOADER).obj + +CORE_H = ..\av.h \ + ..\cop.h \ + ..\cv.h \ + ..\dosish.h \ + ..\embed.h \ + ..\form.h \ + ..\gv.h \ + ..\handy.h \ + ..\hv.h \ + ..\mg.h \ + ..\nostdio.h \ + ..\op.h \ + ..\opcode.h \ + ..\perl.h \ + ..\perlio.h \ + ..\perlsdio.h \ + ..\perlsfio.h \ + ..\perly.h \ + ..\pp.h \ + ..\proto.h \ + ..\regexp.h \ + ..\scope.h \ + ..\sv.h \ + ..\unixish.h \ + ..\util.h \ + ..\XSUB.h \ + .\config.h \ + ..\EXTERN.h \ + .\include\dirent.h \ + .\include\netdb.h \ + .\include\sys\socket.h \ + .\win32.h + + +EXTENSIONS=DynaLoader Socket IO Fcntl Opcode SDBM_File + +DYNALOADER=$(EXTDIR)\DynaLoader\DynaLoader +SOCKET=$(EXTDIR)\Socket\Socket +FCNTL=$(EXTDIR)\Fcntl\Fcntl +OPCODE=$(EXTDIR)\Opcode\Opcode +SDBM_FILE=$(EXTDIR)\SDBM_File\SDBM_File +IO=$(EXTDIR)\IO\IO + +SOCKET_DLL=..\lib\auto\Socket\Socket.dll +FCNTL_DLL=..\lib\auto\Fcntl\Fcntl.dll +OPCODE_DLL=..\lib\auto\Opcode\Opcode.dll +SDBM_FILE_DLL=..\lib\auto\SDBM_File\SDBM_File.dll +IO_DLL=..\lib\auto\IO\IO.dll + +STATICLINKMODULES=DynaLoader +DYNALOADMODULES= \ + $(SOCKET_DLL) \ + $(FCNTL_DLL) \ + $(OPCODE_DLL) \ + $(SDBM_FILE_DLL)\ + $(IO_DLL) + +POD2HTML=$(PODDIR)\pod2html +POD2MAN=$(PODDIR)\pod2man +POD2LATEX=$(PODDIR)\pod2latex +POD2TEXT=$(PODDIR)\pod2text + +# +# Top targets +# + +all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT) + +$(DYNALOADER).obj : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c + +#------------------------------------------------------------ + +$(GLOBEXE): perlglob.obj +.IF "$(CCTYPE)" == "BORLAND" + $(CC) -c -w -v -tWM -I$(CCINCDIR) perlglob.c + $(LINK32) -Tpe -ap $(LINK_FLAGS) c0x32.obj perlglob.obj \ + $(CCLIBDIR)\32BIT\wildargs.obj,$@,,import32.lib cw32mt.lib, +.ELSE + $(LINK32) $(LINK_FLAGS) -out:$@ -subsystem:$(SUBSYS) perlglob.obj setargv.obj +.ENDIF + +$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL) + $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT) + +perlglob.obj : perlglob.c + +..\miniperlmain.obj : ..\miniperlmain.c $(CORE_H) + +config.w32 : $(CFGSH_TMPL) + copy $(CFGSH_TMPL) config.w32 + +.\config.h : $(CFGSH_TMPL) + -del /f config.h + copy $(CFGH_TMPL) config.h + +..\config.sh : config.w32 $(MINIPERL) config_sh.PL + $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \ + "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \ + "cf_email=$(EMAIL)" "libs=$(LIBFILES:f)" "incpath=$(CCINCDIR)" \ + "libpth=$(strip $(CCLIBDIR) $(LIBFILES:d))" "libc=$(LIBC)" \ + config.w32 > ..\config.sh + +$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl + cd .. && miniperl configpm + if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) + $(XCOPY) ..\*.h ..\lib\CORE\*.* + $(XCOPY) *.h ..\lib\CORE\*.* + $(RCOPY) include ..\lib\CORE\*.* + $(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \ + RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM) + +$(MINIPERL) : ..\miniperlmain.obj $(CORE_OBJ) $(WIN32_OBJ) +.IF "$(CCTYPE)" == "BORLAND" + $(LINK32) -Tpe -ap $(LINK_FLAGS) \ + @$(mktmp c0x32.obj ..\miniperlmain.obj \ + $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\),$@,,$(LIBFILES),) +.ELSE + $(LINK32) -subsystem:console -out:$@ \ + @$(mktmp $(LINK_FLAGS) ..\miniperlmain.obj \ + $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\)) +.ENDIF + +$(WIN32_OBJ) : $(CORE_H) +$(CORE_OBJ) : $(CORE_H) +$(DLL_OBJ) : $(CORE_H) + +perldll.def : $(MINIPERL) $(CONFIGPM) + $(MINIPERL) -w makedef.pl $(CCTYPE) > perldll.def + +$(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) +.IF "$(CCTYPE)" == "BORLAND" + $(LINK32) -Tpd -ap $(LINK_FLAGS) \ + @$(mktmp c0d32.obj $(CORE_OBJ:s,\,\\) \ + $(WIN32_OBJ:s,\,\\) $(DLL_OBJ:s,\,\\)\n \ + $@,\n \ + $(LIBFILES)\n \ + perldll.def\n) + $(IMPLIB) $*.lib $@ +.ELSE + $(LINK32) -dll -def:perldll.def -out:$@ \ + @$(mktmp $(LINK_FLAGS) $(CORE_OBJ:s,\,\\) \ + $(WIN32_OBJ:s,\,\\) $(DLL_OBJ:s,\,\\)) +.ENDIF + $(XCOPY) $(PERLIMPLIB) ..\lib\CORE + +perl.def : $(MINIPERL) makeperldef.pl + $(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def + +$(MINIMOD) : $(MINIPERL) ..\minimod.pl + cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm + +perlmain.c : runperl.c + copy runperl.c perlmain.c + +perlmain.obj : perlmain.c + $(CC) $(CFLAGS) -UPERLDLL -c perlmain.c + + +$(PERLEXE): $(PERLDLL) $(CONFIGPM) perlmain.obj +.IF "$(CCTYPE)" == "BORLAND" + $(LINK32) -Tpe -ap $(LINK_FLAGS) \ + @$(mktmp c0x32.obj perlmain.obj $(WINIOMAYBE)\n \ + $@,\n \ + $(PERLIMPLIB) $(LIBFILES)\n) +.ELSE + $(LINK32) -subsystem:console -out:perl.exe $(LINK_FLAGS) \ + perlmain.obj $(WINIOMAYBE) $(PERLIMPLIB) + copy perl.exe $@ + del perl.exe +.ENDIF + copy splittree.pl .. + $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" + attrib -r ..\t\*.* + copy test ..\t + +.IF "$(CCTYPE)" != "BORLAND" + +perl95.c : runperl.c + copy runperl.c perl95.c + +perl95.obj : perl95.c + $(CC) $(CFLAGS) -MT -UPERLDLL -c perl95.c + +win32iomt.obj : win32io.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32iomt.obj win32io.c + +win32sckmt.obj : win32sck.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c + +win32mt.obj : win32.c + $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32mt.obj win32.c + +$(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) + $(LINK32) -subsystem:console -out:perl95.exe $(LINK_FLAGS) \ + $(PERL95_OBJ) $(PERLIMPLIB) + copy perl95.exe $@ + del perl95.exe + +.ENDIF + +$(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) + if not exist ..\lib\auto mkdir ..\lib\auto + $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL) + cd $(EXTDIR)\$(*B) && $(XSUBPP) dl_win32.xs > $(*B).c + $(XCOPY) $(EXTDIR)\$(*B)\dlutils.c . + +$(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs + copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs + +$(IO_DLL): $(PERLEXE) $(CONFIGPM) $(IO).xs + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + +$(SDBM_FILE_DLL) : $(PERLEXE) $(SDBM_FILE).xs + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + +$(FCNTL_DLL): $(PERLEXE) $(FCNTL).xs + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + +$(OPCODE_DLL): $(PERLEXE) $(OPCODE).xs + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + +$(SOCKET_DLL): $(SOCKET).xs $(PERLEXE) + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + +doc: $(PERLEXE) + cd ..\pod && $(MAKE) -f ..\win32\pod.mak checkpods \ + pod2html pod2latex pod2man pod2text + cd ..\pod && $(XCOPY) *.bat ..\win32\bin\*.* + copy ..\README.win32 ..\pod\perlwin32.pod + $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ + --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML:s,:,|,)" \ + --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse + +utils: $(PERLEXE) + cd ..\utils && $(MAKE) PERL=$(MINIPERL) + cd ..\utils && $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug \ + pl2pm c2ph h2xs perldoc pstruct + $(XCOPY) ..\utils\*.bat bin\*.* + $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ + bin\pl2bat.pl + +distclean: clean + -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \ + $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD) + -del /f *.def *.map + -del /f $(SOCKET_DLL) $(IO_DLL) $(SDBM_FILE_DLL) $(FCNTL_DLL) \ + $(OPCODE_DLL) + -del /f $(SOCKET).c $(IO).c $(SDBM_FILE).c $(FCNTL).c $(OPCODE).c \ + $(DYNALOADER).c + -del /f $(PODDIR)\*.html + -del /f $(PODDIR)\*.bat + -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new +.IF "$(PERL95EXE)" != "" + -del /f perl95.c +.ENDIF + -del /f bin\*.bat + -cd $(EXTDIR) && del /s *.lib *.def *.map *.bs Makefile *.obj pm_to_blib + -rmdir /s /q ..\lib\auto + -rmdir /s /q ..\lib\CORE + +install : all doc utils + if not exist $(INST_TOP) mkdir $(INST_TOP) + echo I $(INST_TOP) L $(LIBDIR) + $(XCOPY) $(PERLEXE) $(INST_BIN)\*.* +.IF "$(PERL95EXE)" != "" + $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* +.ENDIF + $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* + $(XCOPY) $(PERLDLL) $(INST_BIN)\*.* + $(XCOPY) bin\*.bat $(INST_BIN)\*.* + $(RCOPY) ..\lib $(INST_LIB)\*.* + $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* + $(XCOPY) ..\pod\*.pod $(INST_POD)\*.* + $(RCOPY) html\*.* $(INST_HTML)\*.* + +inst_lib : $(CONFIGPM) + copy splittree.pl .. + $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" + $(RCOPY) ..\lib $(INST_LIB)\*.* + +minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) + $(XCOPY) $(MINIPERL) ..\t\perl.exe +.IF "$(CCTYPE)" == "BORLAND" + $(XCOPY) $(GLOBBAT) ..\t\$(NULL) +.ELSE + $(XCOPY) $(GLOBEXE) ..\t\$(NULL) +.ENDIF + attrib -r ..\t\*.* + copy test ..\t + cd ..\t && \ + $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t + +test : all + $(XCOPY) $(PERLEXE) ..\t\$(NULL) + $(XCOPY) $(PERLDLL) ..\t\$(NULL) +.IF "$(CCTYPE)" == "BORLAND" + $(XCOPY) $(GLOBBAT) ..\t\$(NULL) +.ELSE + $(XCOPY) $(GLOBEXE) ..\t\$(NULL) +.ENDIF + cd ..\t && $(PERLEXE) -I..\lib harness + +clean : + -@erase miniperlmain.obj + -@erase $(MINIPERL) + -@erase perlglob.obj + -@erase perlmain.obj + -@erase config.w32 + -@erase /f config.h + -@erase $(GLOBEXE) + -@erase $(PERLEXE) + -@erase $(PERLDLL) + -@erase $(CORE_OBJ) + -@erase $(WIN32_OBJ) + -@erase $(DLL_OBJ) + -@erase ..\*.obj ..\*.lib ..\*.exp *.obj *.lib *.exp + -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat + -@erase *.ilk + -@erase *.pdb + + diff --git a/gnu/usr.bin/perl/win32/makemain.pl b/gnu/usr.bin/perl/win32/makemain.pl new file mode 100644 index 00000000000..740b6a212a0 --- /dev/null +++ b/gnu/usr.bin/perl/win32/makemain.pl @@ -0,0 +1,45 @@ +open (MINIMAIN, "<../miniperlmain.c") || die "failed to open miniperlmain.c" . $!; + +while (<MINIMAIN>) { + if (/Do not delete this line--writemain depends on it/) { + last; + } + else { + print $_; + } + }; + +close(MINIMAIN); + +print "char *staticlinkmodules[]={\n"; +foreach (@ARGV) { + print "\t\"".$_."\",\n"; + } +print "\tNULL,\n"; +print "\t};\n"; +print "\n"; +foreach (@ARGV) { + print "EXTERN_C void boot_$_ _((CV* cv));\n" + } + +print <<EOP; + +static void +xs_init() +{ + dXSUB_SYS; + char *file = __FILE__; +EOP + +foreach (@ARGV) { + if (/DynaLoader/) { + print "\tnewXS(\"$_\:\:boot_$_\", boot_$_, file);\n"; + } + else { + print "\tnewXS(\"$_\:\:bootstrap\", boot_$_, file);\n"; + }; + } + +print <<EOP; +} +EOP diff --git a/gnu/usr.bin/perl/win32/makeperldef.pl b/gnu/usr.bin/perl/win32/makeperldef.pl new file mode 100644 index 00000000000..620d2ebab30 --- /dev/null +++ b/gnu/usr.bin/perl/win32/makeperldef.pl @@ -0,0 +1,23 @@ +my $CCTYPE = ""; +print "EXPORTS\n"; +foreach (@ARGV) { + if (/CCTYPE=(.*)$/) { + $CCTYPE = $1; + next; + } + emit_symbol("boot_$_"); +} + +sub emit_symbol { + my $symbol = shift; + if ($CCTYPE eq "BORLAND") { + # workaround Borland quirk by export both the straight + # name and a name with leading underscore + print "\t$symbol=_$symbol\n"; + print "\t_$symbol\n"; + } + else { + print "\t$symbol\n"; + } +} + diff --git a/gnu/usr.bin/perl/win32/perlglob.c b/gnu/usr.bin/perl/win32/perlglob.c new file mode 100644 index 00000000000..b2fdca2f71e --- /dev/null +++ b/gnu/usr.bin/perl/win32/perlglob.c @@ -0,0 +1,42 @@ +/* + * Globbing for NT. Relies on the expansion done by the library + * startup code. + */ + +#include <stdio.h> +#include <io.h> +#include <fcntl.h> +#include <string.h> +#include <windows.h> + +int +main(int argc, char *argv[]) +{ + int i; + int len; + char root[MAX_PATH]; + char *dummy; + char volname[MAX_PATH]; + DWORD serial, maxname, flags; + BOOL downcase = TRUE; + + /* check out the file system characteristics */ + if (GetFullPathName(".", MAX_PATH, root, &dummy)) { + if (dummy = strchr(root, '\\')) + *++dummy = '\0'; + if (GetVolumeInformation(root, volname, MAX_PATH, + &serial, &maxname, &flags, 0, 0)) { + downcase = !(flags & FS_CASE_IS_PRESERVED); + } + } + + setmode(fileno(stdout), O_BINARY); + for (i = 1; i < argc; i++) { + len = strlen(argv[i]); + if (downcase) + strlwr(argv[i]); + if (i > 1) fwrite("\0", sizeof(char), 1, stdout); + fwrite(argv[i], sizeof(char), len, stdout); + } + return 0; +} diff --git a/gnu/usr.bin/perl/win32/perllib.c b/gnu/usr.bin/perl/win32/perllib.c new file mode 100644 index 00000000000..391b4d375f0 --- /dev/null +++ b/gnu/usr.bin/perl/win32/perllib.c @@ -0,0 +1,113 @@ +/* + * "The Road goes ever on and on, down from the door where it began." + */ + +#ifdef __cplusplus +extern "C" { +#endif + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef __cplusplus +} +# define EXTERN_C extern "C" +#else +# define EXTERN_C extern +#endif + +static void xs_init _((void)); + +__declspec(dllexport) int +RunPerl(int argc, char **argv, char **env, void *iosubsystem) +{ + int exitstatus; + PerlInterpreter *my_perl; + void *pOldIOSubsystem; + + pOldIOSubsystem = SetIOSubSystem(iosubsystem); + + PERL_SYS_INIT(&argc,&argv); + + perl_init_i18nl10n(1); + + if (!(my_perl = perl_alloc())) + return (1); + perl_construct( my_perl ); + perl_destruct_level = 0; + + exitstatus = perl_parse( my_perl, xs_init, argc, argv, env); + if (!exitstatus) { + exitstatus = perl_run( my_perl ); + } + + perl_destruct( my_perl ); + perl_free( my_perl ); + + PERL_SYS_TERM(); + + SetIOSubSystem(pOldIOSubsystem); + + return (exitstatus); +} + +extern HANDLE PerlDllHandle; + +BOOL APIENTRY +DllMain(HANDLE hModule, /* DLL module handle */ + DWORD fdwReason, /* reason called */ + LPVOID lpvReserved) /* reserved */ +{ + switch (fdwReason) { + /* The DLL is attaching to a process due to process + * initialization or a call to LoadLibrary. + */ + case DLL_PROCESS_ATTACH: +/* #define DEFAULT_BINMODE */ +#ifdef DEFAULT_BINMODE + setmode( fileno( stdin ), O_BINARY ); + setmode( fileno( stdout ), O_BINARY ); + setmode( fileno( stderr ), O_BINARY ); + _fmode = O_BINARY; +#endif + PerlDllHandle = hModule; + break; + + /* The DLL is detaching from a process due to + * process termination or call to FreeLibrary. + */ + case DLL_PROCESS_DETACH: + break; + + /* The attached process creates a new thread. */ + case DLL_THREAD_ATTACH: + break; + + /* The thread of the attached process terminates. */ + case DLL_THREAD_DETACH: + break; + + default: + break; + } + return TRUE; +} + +/* Register any extra external extensions */ + +char *staticlinkmodules[] = { + "DynaLoader", + NULL, +}; + +EXTERN_C void boot_DynaLoader _((CV* cv)); + +static void +xs_init() +{ + char *file = __FILE__; + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); +} + diff --git a/gnu/usr.bin/perl/win32/pod.mak b/gnu/usr.bin/perl/win32/pod.mak new file mode 100644 index 00000000000..9881ed882d6 --- /dev/null +++ b/gnu/usr.bin/perl/win32/pod.mak @@ -0,0 +1,272 @@ +CONVERTERS = pod2html pod2latex pod2man pod2text checkpods + +HTMLROOT = / # Change this to fix cross-references in HTML +POD2HTML = pod2html \ + --htmlroot=$(HTMLROOT) \ + --podroot=.. --podpath=pod:lib:ext:vms \ + --libpods=perlfunc:perlguts:perlvar:perlrun:perlop + +all: $(CONVERTERS) html + +PERL = ..\miniperl.exe +PL2BAT = ..\win32\bin\pl2bat.pl + +POD = \ + perl.pod \ + perldelta.pod \ + perldata.pod \ + perlsyn.pod \ + perlop.pod \ + perlre.pod \ + perlrun.pod \ + perlfunc.pod \ + perlvar.pod \ + perlsub.pod \ + perlmod.pod \ + perlform.pod \ + perllocale.pod \ + perlref.pod \ + perldsc.pod \ + perllol.pod \ + perltoot.pod \ + perlobj.pod \ + perltie.pod \ + perlbot.pod \ + perlipc.pod \ + perldebug.pod \ + perldiag.pod \ + perlsec.pod \ + perltrap.pod \ + perlstyle.pod \ + perlpod.pod \ + perlbook.pod \ + perlembed.pod \ + perlapio.pod \ + perlxs.pod \ + perlxstut.pod \ + perlguts.pod \ + perlcall.pod \ + perlfaq.pod \ + perlfaq1.pod \ + perlfaq2.pod \ + perlfaq3.pod \ + perlfaq4.pod \ + perlfaq5.pod \ + perlfaq6.pod \ + perlfaq7.pod \ + perlfaq8.pod \ + perlfaq9.pod \ + perltoc.pod + +MAN = \ + perl.man \ + perldelta.man \ + perldata.man \ + perlsyn.man \ + perlop.man \ + perlre.man \ + perlrun.man \ + perlfunc.man \ + perlvar.man \ + perlsub.man \ + perlmod.man \ + perlform.man \ + perllocale.man \ + perlref.man \ + perldsc.man \ + perllol.man \ + perltoot.man \ + perlobj.man \ + perltie.man \ + perlbot.man \ + perlipc.man \ + perldebug.man \ + perldiag.man \ + perlsec.man \ + perltrap.man \ + perlstyle.man \ + perlpod.man \ + perlbook.man \ + perlembed.man \ + perlapio.man \ + perlxs.man \ + perlxstut.man \ + perlguts.man \ + perlcall.man \ + perlfaq.man \ + perlfaq1.man \ + perlfaq2.man \ + perlfaq3.man \ + perlfaq4.man \ + perlfaq5.man \ + perlfaq6.man \ + perlfaq7.man \ + perlfaq8.man \ + perlfaq9.man \ + perltoc.man + +HTML = \ + perl.html \ + perldelta.html \ + perldata.html \ + perlsyn.html \ + perlop.html \ + perlre.html \ + perlrun.html \ + perlfunc.html \ + perlvar.html \ + perlsub.html \ + perlmod.html \ + perlform.html \ + perllocale.html \ + perlref.html \ + perldsc.html \ + perllol.html \ + perltoot.html \ + perlobj.html \ + perltie.html \ + perlbot.html \ + perlipc.html \ + perldebug.html \ + perldiag.html \ + perlsec.html \ + perltrap.html \ + perlstyle.html \ + perlpod.html \ + perlbook.html \ + perlembed.html \ + perlapio.html \ + perlxs.html \ + perlxstut.html \ + perlguts.html \ + perlcall.html \ + perlfaq.html \ + perlfaq1.html \ + perlfaq2.html \ + perlfaq3.html \ + perlfaq4.html \ + perlfaq5.html \ + perlfaq6.html \ + perlfaq7.html \ + perlfaq8.html \ + perlfaq9.html +# not perltoc.html + +TEX = \ + perl.tex \ + perldelta.tex \ + perldata.tex \ + perlsyn.tex \ + perlop.tex \ + perlre.tex \ + perlrun.tex \ + perlfunc.tex \ + perlvar.tex \ + perlsub.tex \ + perlmod.tex \ + perlform.tex \ + perllocale.tex \ + perlref.tex \ + perldsc.tex \ + perllol.tex \ + perltoot.tex \ + perlobj.tex \ + perltie.tex \ + perlbot.tex \ + perlipc.tex \ + perldebug.tex \ + perldiag.tex \ + perlsec.tex \ + perltrap.tex \ + perlstyle.tex \ + perlpod.tex \ + perlbook.tex \ + perlembed.tex \ + perlapio.tex \ + perlxs.tex \ + perlxstut.tex \ + perlguts.tex \ + perlcall.tex \ + perlfaq.tex \ + perlfaq1.tex \ + perlfaq2.tex \ + perlfaq3.tex \ + perlfaq4.tex \ + perlfaq5.tex \ + perlfaq6.tex \ + perlfaq7.tex \ + perlfaq8.tex \ + perlfaq9.tex \ + perltoc.tex + +man: pod2man $(MAN) + +html: pod2html $(HTML) + +tex: pod2latex $(TEX) + +toc: + $(PERL) -I..\lib buildtoc >perltoc.pod + +.SUFFIXES: .pm .pod + +.SUFFIXES: .man + +.pm.man: + $(PERL) -I..\lib pod2man $*.pm >$*.man + +.pod.man: + $(PERL) -I..\lib pod2man $*.pod >$*.man + +.SUFFIXES: .html + +.pm.html: + $(PERL) -I..\lib $(POD2HTML) --infile=$*.pm --outfile=$*.html + +.pod.html: + $(PERL) -I..\lib $(POD2HTML) --infile=$*.pod --outfile=$*.html + +.SUFFIXES: .tex + +.pm.tex: + $(PERL) -I..\lib pod2latex $*.pm + +.pod.tex: + $(PERL) -I..\lib pod2latex $*.pod + +clean: + del /f $(MAN) $(HTML) $(TEX) + del /f pod2html-*cache + del /f *.aux *.log + +realclean: clean + del /f $(CONVERTERS) + +distclean: realclean + +check: checkpods + @echo "checking..."; \ + $(PERL) -I..\lib checkpods $(POD) + +# Dependencies. +pod2latex: pod2latex.PL ..\lib\Config.pm + $(PERL) -I..\lib pod2latex.PL + $(PERL) $(PL2BAT) pod2latex + +pod2html: pod2html.PL ..\lib\Config.pm + $(PERL) -I..\lib pod2html.PL + $(PERL) $(PL2BAT) pod2html + +pod2man: pod2man.PL ..\lib\Config.pm + $(PERL) -I..\lib pod2man.PL + $(PERL) $(PL2BAT) pod2man + +pod2text: pod2text.PL ..\lib\Config.pm + $(PERL) -I..\lib pod2text.PL + $(PERL) $(PL2BAT) pod2text + +checkpods: checkpods.PL ..\lib\Config.pm + $(PERL) -I..\lib checkpods.PL + $(PERL) $(PL2BAT) checkpods + + diff --git a/gnu/usr.bin/perl/win32/runperl.c b/gnu/usr.bin/perl/win32/runperl.c new file mode 100644 index 00000000000..07e2bd6f835 --- /dev/null +++ b/gnu/usr.bin/perl/win32/runperl.c @@ -0,0 +1,18 @@ +#include <stdio.h> +#include <win32io.h> + +#ifndef _DLL +extern WIN32_IOSUBSYSTEM win32stdio; +#endif + +extern int RunPerl(int argc, char **argv, char **env, void *iosubsystem); + +int +main(int argc, char **argv, char **env) +{ +#ifdef _DLL + return (RunPerl(argc, argv, env, NULL)); +#else + return (RunPerl(argc, argv, env, &win32stdio)); +#endif +} diff --git a/gnu/usr.bin/perl/win32/splittree.pl b/gnu/usr.bin/perl/win32/splittree.pl new file mode 100644 index 00000000000..3c76daadb1c --- /dev/null +++ b/gnu/usr.bin/perl/win32/splittree.pl @@ -0,0 +1,24 @@ +use DirHandle; +use AutoSplit; + +sub splitthis { +my ($top,$base,$dest) = @_; +my $d = new DirHandle $base; +if (defined $d) { + while (defined($_ = $d->read)) { + next if $_ eq "."; + next if $_ eq ".."; + my $entry = "$base\\$_"; + my $entrywithouttop = $entry; + $entrywithouttop =~ s/^$top//; + if (-d $entry) {splitthis ($top,$entry,$dest);} + else { + next unless ($entry=~/pm$/i); + #print "Will run autosplit on $entry to $dest\n"; + autosplit($entry,$dest,0,1,1); + }; + }; + }; +} + +splitthis $ARGV[0],$ARGV[0],$ARGV[1]; diff --git a/gnu/usr.bin/perl/win32/win32.c b/gnu/usr.bin/perl/win32/win32.c new file mode 100644 index 00000000000..7cbfae8a83d --- /dev/null +++ b/gnu/usr.bin/perl/win32/win32.c @@ -0,0 +1,1639 @@ +/* WIN32.C + * + * (c) 1995 Microsoft Corporation. All rights reserved. + * Developed by hip communications inc., http://info.hip.com/info/ + * Portions (c) 1993 Intergraph Corporation. All rights reserved. + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + */ + +#define WIN32_LEAN_AND_MEAN +#define WIN32IO_IS_STDIO +#include <tchar.h> +#include <windows.h> + +/* #include "config.h" */ + +#define PERLIO_NOT_STDIO 0 +#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) +#define PerlIO FILE +#endif + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <fcntl.h> +#include <sys/stat.h> +#include <assert.h> +#include <string.h> +#include <stdarg.h> +#include <float.h> + +#define CROAK croak +#define WARN warn + +#define EXECF_EXEC 1 +#define EXECF_SPAWN 2 +#define EXECF_SPAWN_NOWAIT 3 + +static DWORD IdOS(void); + +extern WIN32_IOSUBSYSTEM win32stdio; +static PWIN32_IOSUBSYSTEM pIOSubSystem = &win32stdio; + +BOOL ProbeEnv = FALSE; +DWORD Win32System = (DWORD)-1; +char szShellPath[MAX_PATH+1]; +char szPerlLibRoot[MAX_PATH+1]; +HANDLE PerlDllHandle = INVALID_HANDLE_VALUE; + +static int do_spawn2(char *cmd, int exectype); + +int +IsWin95(void) { + return (IdOS() == VER_PLATFORM_WIN32_WINDOWS); +} + +int +IsWinNT(void) { + return (IdOS() == VER_PLATFORM_WIN32_NT); +} + +DllExport PWIN32_IOSUBSYSTEM +SetIOSubSystem(void *p) +{ + PWIN32_IOSUBSYSTEM old = pIOSubSystem; + if (p) { + PWIN32_IOSUBSYSTEM pio = (PWIN32_IOSUBSYSTEM)p; + if (pio->signature_begin == 12345678L + && pio->signature_end == 87654321L) { + pIOSubSystem = pio; + } + } + else { + pIOSubSystem = &win32stdio; + } + return old; +} + +DllExport PWIN32_IOSUBSYSTEM +GetIOSubSystem(void) +{ + return pIOSubSystem; +} + +char * +win32PerlLibPath(void) +{ + char *end; + GetModuleFileName((PerlDllHandle == INVALID_HANDLE_VALUE) + ? GetModuleHandle(NULL) + : PerlDllHandle, + szPerlLibRoot, + sizeof(szPerlLibRoot)); + + *(end = strrchr(szPerlLibRoot, '\\')) = '\0'; + if (stricmp(end-4,"\\bin") == 0) + end -= 4; + strcpy(end,"\\lib"); + return (szPerlLibRoot); +} + +char * +win32SiteLibPath(void) +{ + static char szPerlSiteLib[MAX_PATH+1]; + strcpy(szPerlSiteLib, win32PerlLibPath()); + strcat(szPerlSiteLib, "\\site"); + return (szPerlSiteLib); +} + +BOOL +HasRedirection(char *ptr) +{ + int inquote = 0; + char quote = '\0'; + + /* + * Scan string looking for redirection (< or >) or pipe + * characters (|) that are not in a quoted string + */ + while(*ptr) { + switch(*ptr) { + case '\'': + case '\"': + if(inquote) { + if(quote == *ptr) { + inquote = 0; + quote = '\0'; + } + } + else { + quote = *ptr; + inquote++; + } + break; + case '>': + case '<': + case '|': + if(!inquote) + return TRUE; + default: + break; + } + ++ptr; + } + return FALSE; +} + +/* since the current process environment is being updated in util.c + * the library functions will get the correct environment + */ +PerlIO * +my_popen(char *cmd, char *mode) +{ +#ifdef FIXCMD +#define fixcmd(x) { \ + char *pspace = strchr((x),' '); \ + if (pspace) { \ + char *p = (x); \ + while (p < pspace) { \ + if (*p == '/') \ + *p = '\\'; \ + p++; \ + } \ + } \ + } +#else +#define fixcmd(x) +#endif + +#if 1 +/* was #ifndef PERLDLL, but the #else stuff doesn't work on NT + * GSAR 97/03/13 + */ + fixcmd(cmd); +#ifdef __BORLANDC__ /* workaround a Borland stdio bug */ + win32_fflush(stdout); + win32_fflush(stderr); +#endif + return win32_popen(cmd, mode); +#else +/* + * There seems to be some problems for the _popen call in a DLL + * this trick at the moment seems to work but it is never test + * on NT yet + * + */ +# ifdef __cplusplus +#define EXT_C_FUNC extern "C" +# else +#define EXT_C_FUNC extern +# endif + + EXT_C_FUNC int __cdecl _set_osfhnd(int fh, long value); + EXT_C_FUNC void __cdecl _lock_fhandle(int); + EXT_C_FUNC void __cdecl _unlock_fhandle(int); + + BOOL fSuccess; + PerlIO *pf; /* to store the _popen return value */ + int tm = 0; /* flag indicating tDllExport or binary mode */ + int fhNeeded, fhInherited, fhDup; + int ineeded, iinherited; + DWORD dwDup; + int phdls[2]; /* I/O handles for pipe */ + HANDLE hPIn, hPOut, hPErr, + hSaveStdin, hSaveStdout, hSaveStderr, + hPNeeded, hPInherited, hPDuped; + + /* first check for errors in the arguments */ + if ( (cmd == NULL) || (mode == NULL) + || ((*mode != 'w') && (*mode != _T('r'))) ) + goto error1; + + if ( *(mode + 1) == _T('t') ) + tm = O_TEXT; + else if ( *(mode + 1) == _T('b') ) + tm = O_BINARY; + else + tm = (*mode == 'w' ? O_BINARY : O_TEXT); + + + fixcmd(cmd); + if (&win32stdio != pIOSubSystem) + return win32_popen(cmd, mode); + +#ifdef EFG + if ( _pipe( phdls, 1024, tm ) == -1 ) +#else + if ( win32_pipe( phdls, 1024, tm ) == -1 ) +#endif + goto error1; + + /* save the current situation */ + hSaveStdin = GetStdHandle(STD_INPUT_HANDLE); + hSaveStdout = GetStdHandle(STD_OUTPUT_HANDLE); + hSaveStderr = GetStdHandle(STD_ERROR_HANDLE); + + if (*mode == _T('w')) { + ineeded = 1; + dwDup = STD_INPUT_HANDLE; + iinherited = 0; + } + else { + ineeded = 0; + dwDup = STD_OUTPUT_HANDLE; + iinherited = 1; + } + + fhNeeded = phdls[ineeded]; + fhInherited = phdls[iinherited]; + + fSuccess = DuplicateHandle(GetCurrentProcess(), + (HANDLE) stolen_get_osfhandle(fhNeeded), + GetCurrentProcess(), + &hPNeeded, + 0, + FALSE, /* not inherited */ + DUPLICATE_SAME_ACCESS); + + if (!fSuccess) + goto error2; + + fhDup = stolen_open_osfhandle((long) hPNeeded, tm); + win32_dup2(fhDup, fhNeeded); + win32_close(fhDup); + +#ifdef AAA + /* Close the Out pipe, child won't need it */ + hPDuped = (HANDLE) stolen_get_osfhandle(fhNeeded); + + _lock_fhandle(fhNeeded); + _set_osfhnd(fhNeeded, (long)hPNeeded); /* put in ours duplicated one */ + _unlock_fhandle(fhNeeded); + + CloseHandle(hPDuped); /* close the handle first */ +#endif + + if (!SetStdHandle(dwDup, (HANDLE) stolen_get_osfhandle(fhInherited))) + goto error2; + + /* + * make sure the child see the same stderr as the calling program + */ + if (!SetStdHandle(STD_ERROR_HANDLE, + (HANDLE)stolen_get_osfhandle(win32_fileno(win32_stderr())))) + goto error2; + + pf = win32_popen(cmd, mode); /* ask _popen to do the job */ + + /* restore to where we were */ + SetStdHandle(STD_INPUT_HANDLE, hSaveStdin); + SetStdHandle(STD_OUTPUT_HANDLE, hSaveStdout); + SetStdHandle(STD_ERROR_HANDLE, hSaveStderr); + + /* we don't need it any more, that's for the child */ + win32_close(fhInherited); + + if (NULL == pf) { + /* something wrong */ + win32_close(fhNeeded); + goto error1; + } + else { + /* + * here we steal the file handle in pf and stuff ours in + */ + win32_dup2(fhNeeded, win32_fileno(pf)); + win32_close(fhNeeded); + } + return (pf); + +error2: + win32_close(fhNeeded); + win32_close(fhInherited); + +error1: + return (NULL); + +#endif +} + +long +my_pclose(PerlIO *fp) +{ + return win32_pclose(fp); +} + +static DWORD +IdOS(void) +{ + static OSVERSIONINFO osver; + + if (osver.dwPlatformId != Win32System) { + memset(&osver, 0, sizeof(OSVERSIONINFO)); + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&osver); + Win32System = osver.dwPlatformId; + } + return (Win32System); +} + +static char * +GetShell(void) +{ + if (!ProbeEnv) { + char* defaultshell = (IsWinNT() ? "cmd.exe" : "command.com"); + /* we don't use COMSPEC here for two reasons: + * 1. the same reason perl on UNIX doesn't use SHELL--rampant and + * uncontrolled unportability of the ensuing scripts. + * 2. PERL5SHELL could be set to a shell that may not be fit for + * interactive use (which is what most programs look in COMSPEC + * for). + */ + char *usershell = getenv("PERL5SHELL"); + + ProbeEnv = TRUE; + strcpy(szShellPath, usershell ? usershell : defaultshell); + } + return szShellPath; +} + +int +do_aspawn(void* really, void** mark, void** arglast) +{ + char **argv; + char *strPtr; + char *cmd; + int status; + unsigned int length; + int index = 0; + SV *sv = (SV*)really; + SV** pSv = (SV**)mark; + + New(1310, argv, (arglast - mark) + 4, char*); + + if(sv != Nullsv) { + cmd = SvPV(sv, length); + } + else { + argv[index++] = cmd = GetShell(); + if (IsWinNT()) + argv[index++] = "/x"; /* always enable command extensions */ + argv[index++] = "/c"; + } + + while(++pSv <= (SV**)arglast) { + sv = *pSv; + strPtr = SvPV(sv, length); + if(strPtr != NULL && *strPtr != '\0') + argv[index++] = strPtr; + } + argv[index++] = 0; + + status = win32_spawnvp(P_WAIT, cmd, (const char* const*)argv); + + Safefree(argv); + + if (status < 0) { + if (dowarn) + warn("Can't spawn \"%s\": %s", cmd, strerror(errno)); + status = 255 << 8; + } + return (status); +} + +int +do_spawn2(char *cmd, int exectype) +{ + char **a; + char *s; + char **argv; + int status = -1; + BOOL needToTry = TRUE; + char *shell, *cmd2; + + /* save an extra exec if possible */ + shell = GetShell(); + + /* see if there are shell metacharacters in it */ + if(!HasRedirection(cmd)) { + New(1301,argv, strlen(cmd) / 2 + 2, char*); + New(1302,cmd2, strlen(cmd) + 1, char); + strcpy(cmd2, cmd); + a = argv; + for (s = cmd2; *s;) { + while (*s && isspace(*s)) + s++; + if (*s) + *(a++) = s; + while(*s && !isspace(*s)) + s++; + if(*s) + *s++ = '\0'; + } + *a = Nullch; + if(argv[0]) { + switch (exectype) { + case EXECF_SPAWN: + status = win32_spawnvp(P_WAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_SPAWN_NOWAIT: + status = win32_spawnvp(P_NOWAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_EXEC: + status = win32_execvp(argv[0], (const char* const*)argv); + break; + } + if(status != -1 || errno == 0) + needToTry = FALSE; + } + Safefree(argv); + Safefree(cmd2); + } + if(needToTry) { + char *argv[5]; + int i = 0; + argv[i++] = shell; + if (IsWinNT()) + argv[i++] = "/x"; + argv[i++] = "/c"; argv[i++] = cmd; argv[i] = Nullch; + switch (exectype) { + case EXECF_SPAWN: + status = win32_spawnvp(P_WAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_SPAWN_NOWAIT: + status = win32_spawnvp(P_NOWAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_EXEC: + status = win32_execvp(argv[0], (const char* const*)argv); + break; + } + } + if (status < 0) { + if (dowarn) + warn("Can't %s \"%s\": %s", + (exectype == EXECF_EXEC ? "exec" : "spawn"), + needToTry ? shell : argv[0], + strerror(errno)); + status = 255 << 8; + } + return (status); +} + +int +do_spawn(char *cmd) +{ + return do_spawn2(cmd, EXECF_SPAWN); +} + +bool +do_exec(char *cmd) +{ + do_spawn2(cmd, EXECF_EXEC); + return FALSE; +} + + +#define PATHLEN 1024 + +/* The idea here is to read all the directory names into a string table + * (separated by nulls) and when one of the other dir functions is called + * return the pointer to the current file name. + */ +DIR * +opendir(char *filename) +{ + DIR *p; + long len; + long idx; + char scannamespc[PATHLEN]; + char *scanname = scannamespc; + struct stat sbuf; + WIN32_FIND_DATA FindData; + HANDLE fh; +/* char root[_MAX_PATH];*/ +/* char volname[_MAX_PATH];*/ +/* DWORD serial, maxname, flags;*/ +/* BOOL downcase;*/ +/* char *dummy;*/ + + /* check to see if filename is a directory */ + if (win32_stat(filename, &sbuf) < 0 || sbuf.st_mode & S_IFDIR == 0) { + return NULL; + } + + /* get the file system characteristics */ +/* if(GetFullPathName(filename, MAX_PATH, root, &dummy)) { + * if(dummy = strchr(root, '\\')) + * *++dummy = '\0'; + * if(GetVolumeInformation(root, volname, MAX_PATH, &serial, + * &maxname, &flags, 0, 0)) { + * downcase = !(flags & FS_CASE_IS_PRESERVED); + * } + * } + * else { + * downcase = TRUE; + * } + */ + /* Get us a DIR structure */ + Newz(1303, p, 1, DIR); + if(p == NULL) + return NULL; + + /* Create the search pattern */ + strcpy(scanname, filename); + + if(index("/\\", *(scanname + strlen(scanname) - 1)) == NULL) + strcat(scanname, "/*"); + else + strcat(scanname, "*"); + + /* do the FindFirstFile call */ + fh = FindFirstFile(scanname, &FindData); + if(fh == INVALID_HANDLE_VALUE) { + return NULL; + } + + /* now allocate the first part of the string table for + * the filenames that we find. + */ + idx = strlen(FindData.cFileName)+1; + New(1304, p->start, idx, char); + if(p->start == NULL) { + CROAK("opendir: malloc failed!\n"); + } + strcpy(p->start, FindData.cFileName); +/* if(downcase) + * strlwr(p->start); + */ + p->nfiles++; + + /* loop finding all the files that match the wildcard + * (which should be all of them in this directory!). + * the variable idx should point one past the null terminator + * of the previous string found. + */ + while (FindNextFile(fh, &FindData)) { + len = strlen(FindData.cFileName); + /* bump the string table size by enough for the + * new name and it's null terminator + */ + Renew(p->start, idx+len+1, char); + if(p->start == NULL) { + CROAK("opendir: malloc failed!\n"); + } + strcpy(&p->start[idx], FindData.cFileName); +/* if (downcase) + * strlwr(&p->start[idx]); + */ + p->nfiles++; + idx += len+1; + } + FindClose(fh); + p->size = idx; + p->curr = p->start; + return p; +} + + +/* Readdir just returns the current string pointer and bumps the + * string pointer to the nDllExport entry. + */ +struct direct * +readdir(DIR *dirp) +{ + int len; + static int dummy = 0; + + if (dirp->curr) { + /* first set up the structure to return */ + len = strlen(dirp->curr); + strcpy(dirp->dirstr.d_name, dirp->curr); + dirp->dirstr.d_namlen = len; + + /* Fake an inode */ + dirp->dirstr.d_ino = dummy++; + + /* Now set up for the nDllExport call to readdir */ + dirp->curr += len + 1; + if (dirp->curr >= (dirp->start + dirp->size)) { + dirp->curr = NULL; + } + + return &(dirp->dirstr); + } + else + return NULL; +} + +/* Telldir returns the current string pointer position */ +long +telldir(DIR *dirp) +{ + return (long) dirp->curr; +} + + +/* Seekdir moves the string pointer to a previously saved position + *(Saved by telldir). + */ +void +seekdir(DIR *dirp, long loc) +{ + dirp->curr = (char *)loc; +} + +/* Rewinddir resets the string pointer to the start */ +void +rewinddir(DIR *dirp) +{ + dirp->curr = dirp->start; +} + +/* free the memory allocated by opendir */ +int +closedir(DIR *dirp) +{ + Safefree(dirp->start); + Safefree(dirp); + return 1; +} + + +/* + * various stubs + */ + + +/* Ownership + * + * Just pretend that everyone is a superuser. NT will let us know if + * we don\'t really have permission to do something. + */ + +#define ROOT_UID ((uid_t)0) +#define ROOT_GID ((gid_t)0) + +uid_t +getuid(void) +{ + return ROOT_UID; +} + +uid_t +geteuid(void) +{ + return ROOT_UID; +} + +gid_t +getgid(void) +{ + return ROOT_GID; +} + +gid_t +getegid(void) +{ + return ROOT_GID; +} + +int +setuid(uid_t uid) +{ + return (uid == ROOT_UID ? 0 : -1); +} + +int +setgid(gid_t gid) +{ + return (gid == ROOT_GID ? 0 : -1); +} + +/* + * pretended kill + */ +int +kill(int pid, int sig) +{ + HANDLE hProcess= OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid); + + if (hProcess == NULL) { + CROAK("kill process failed!\n"); + } + else { + if (!TerminateProcess(hProcess, sig)) + CROAK("kill process failed!\n"); + CloseHandle(hProcess); + } + return 0; +} + +/* + * File system stuff + */ + +#if 0 +int +ioctl(int i, unsigned int u, char *data) +{ + CROAK("ioctl not implemented!\n"); + return -1; +} +#endif + +unsigned int +sleep(unsigned int t) +{ + Sleep(t*1000); + return 0; +} + + +#undef rename + +int +myrename(char *OldFileName, char *newname) +{ + if(_access(newname, 0) != -1) { /* file exists */ + _unlink(newname); + } + return rename(OldFileName, newname); +} + + +DllExport int +win32_stat(const char *path, struct stat *buffer) +{ + char t[MAX_PATH]; + const char *p = path; + int l = strlen(path); + int res; + + if (l > 1) { + switch(path[l - 1]) { + case '\\': + case '/': + if (path[l - 2] != ':') { + strncpy(t, path, l - 1); + t[l - 1] = 0; + p = t; + }; + } + } + res = pIOSubSystem->pfnstat(p,buffer); +#ifdef __BORLANDC__ + if (res == 0) { + if (S_ISDIR(buffer->st_mode)) + buffer->st_mode |= S_IWRITE | S_IEXEC; + else if (S_ISREG(buffer->st_mode)) { + if (l >= 4 && path[l-4] == '.') { + const char *e = path + l - 3; + if (strnicmp(e,"exe",3) + && strnicmp(e,"bat",3) + && strnicmp(e,"com",3) + && (IsWin95() || strnicmp(e,"cmd",3))) + buffer->st_mode &= ~S_IEXEC; + else + buffer->st_mode |= S_IEXEC; + } + else + buffer->st_mode &= ~S_IEXEC; + } + } +#endif + return res; +} + +#ifndef USE_WIN32_RTL_ENV + +DllExport char * +win32_getenv(const char *name) +{ + static char *curitem = Nullch; + static DWORD curlen = 512; + DWORD needlen; + if (!curitem) + New(1305,curitem,curlen,char); + if (!(needlen = GetEnvironmentVariable(name,curitem,curlen))) + return Nullch; + while (needlen > curlen) { + Renew(curitem,needlen,char); + curlen = needlen; + needlen = GetEnvironmentVariable(name,curitem,curlen); + } + return curitem; +} + +#endif + +#undef times +int +mytimes(struct tms *timebuf) +{ + clock_t t = clock(); + timebuf->tms_utime = t; + timebuf->tms_stime = 0; + timebuf->tms_cutime = 0; + timebuf->tms_cstime = 0; + + return 0; +} + +#undef alarm +unsigned int +myalarm(unsigned int sec) +{ + /* we warn the usuage of alarm function */ + if (sec != 0) + WARN("dummy function alarm called, program might not function as expected\n"); + return 0; +} + +/* + * redirected io subsystem for all XS modules + * + */ + +DllExport int * +win32_errno(void) +{ + return (pIOSubSystem->pfnerrno()); +} + +DllExport char *** +win32_environ(void) +{ + return (pIOSubSystem->pfnenviron()); +} + +/* the rest are the remapped stdio routines */ +DllExport FILE * +win32_stderr(void) +{ + return (pIOSubSystem->pfnstderr()); +} + +DllExport FILE * +win32_stdin(void) +{ + return (pIOSubSystem->pfnstdin()); +} + +DllExport FILE * +win32_stdout() +{ + return (pIOSubSystem->pfnstdout()); +} + +DllExport int +win32_ferror(FILE *fp) +{ + return (pIOSubSystem->pfnferror(fp)); +} + + +DllExport int +win32_feof(FILE *fp) +{ + return (pIOSubSystem->pfnfeof(fp)); +} + +/* + * Since the errors returned by the socket error function + * WSAGetLastError() are not known by the library routine strerror + * we have to roll our own. + */ + +__declspec(thread) char strerror_buffer[512]; + +DllExport char * +win32_strerror(int e) +{ +#ifndef __BORLANDC__ /* Borland intolerance */ + extern int sys_nerr; +#endif + DWORD source = 0; + + if(e < 0 || e > sys_nerr) { + if(e < 0) + e = GetLastError(); + + if(FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0, + strerror_buffer, sizeof(strerror_buffer), NULL) == 0) + strcpy(strerror_buffer, "Unknown Error"); + + return strerror_buffer; + } + return pIOSubSystem->pfnstrerror(e); +} + +DllExport int +win32_fprintf(FILE *fp, const char *format, ...) +{ + va_list marker; + va_start(marker, format); /* Initialize variable arguments. */ + + return (pIOSubSystem->pfnvfprintf(fp, format, marker)); +} + +DllExport int +win32_printf(const char *format, ...) +{ + va_list marker; + va_start(marker, format); /* Initialize variable arguments. */ + + return (pIOSubSystem->pfnvprintf(format, marker)); +} + +DllExport int +win32_vfprintf(FILE *fp, const char *format, va_list args) +{ + return (pIOSubSystem->pfnvfprintf(fp, format, args)); +} + +DllExport int +win32_vprintf(const char *format, va_list args) +{ + return (pIOSubSystem->pfnvprintf(format, args)); +} + +DllExport size_t +win32_fread(void *buf, size_t size, size_t count, FILE *fp) +{ + return pIOSubSystem->pfnfread(buf, size, count, fp); +} + +DllExport size_t +win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp) +{ + return pIOSubSystem->pfnfwrite(buf, size, count, fp); +} + +DllExport FILE * +win32_fopen(const char *filename, const char *mode) +{ + if (stricmp(filename, "/dev/null")==0) + return pIOSubSystem->pfnfopen("NUL", mode); + return pIOSubSystem->pfnfopen(filename, mode); +} + +DllExport FILE * +win32_fdopen( int handle, const char *mode) +{ + return pIOSubSystem->pfnfdopen(handle, mode); +} + +DllExport FILE * +win32_freopen( const char *path, const char *mode, FILE *stream) +{ + if (stricmp(path, "/dev/null")==0) + return pIOSubSystem->pfnfreopen("NUL", mode, stream); + return pIOSubSystem->pfnfreopen(path, mode, stream); +} + +DllExport int +win32_fclose(FILE *pf) +{ + return pIOSubSystem->pfnfclose(pf); +} + +DllExport int +win32_fputs(const char *s,FILE *pf) +{ + return pIOSubSystem->pfnfputs(s, pf); +} + +DllExport int +win32_fputc(int c,FILE *pf) +{ + return pIOSubSystem->pfnfputc(c,pf); +} + +DllExport int +win32_ungetc(int c,FILE *pf) +{ + return pIOSubSystem->pfnungetc(c,pf); +} + +DllExport int +win32_getc(FILE *pf) +{ + return pIOSubSystem->pfngetc(pf); +} + +DllExport int +win32_fileno(FILE *pf) +{ + return pIOSubSystem->pfnfileno(pf); +} + +DllExport void +win32_clearerr(FILE *pf) +{ + pIOSubSystem->pfnclearerr(pf); + return; +} + +DllExport int +win32_fflush(FILE *pf) +{ + return pIOSubSystem->pfnfflush(pf); +} + +DllExport long +win32_ftell(FILE *pf) +{ + return pIOSubSystem->pfnftell(pf); +} + +DllExport int +win32_fseek(FILE *pf,long offset,int origin) +{ + return pIOSubSystem->pfnfseek(pf, offset, origin); +} + +DllExport int +win32_fgetpos(FILE *pf,fpos_t *p) +{ + return pIOSubSystem->pfnfgetpos(pf, p); +} + +DllExport int +win32_fsetpos(FILE *pf,const fpos_t *p) +{ + return pIOSubSystem->pfnfsetpos(pf, p); +} + +DllExport void +win32_rewind(FILE *pf) +{ + pIOSubSystem->pfnrewind(pf); + return; +} + +DllExport FILE* +win32_tmpfile(void) +{ + return pIOSubSystem->pfntmpfile(); +} + +DllExport void +win32_abort(void) +{ + pIOSubSystem->pfnabort(); + return; +} + +DllExport int +win32_fstat(int fd,struct stat *bufptr) +{ + return pIOSubSystem->pfnfstat(fd,bufptr); +} + +DllExport int +win32_pipe(int *pfd, unsigned int size, int mode) +{ + return pIOSubSystem->pfnpipe(pfd, size, mode); +} + +DllExport FILE* +win32_popen(const char *command, const char *mode) +{ + return pIOSubSystem->pfnpopen(command, mode); +} + +DllExport int +win32_pclose(FILE *pf) +{ + return pIOSubSystem->pfnpclose(pf); +} + +DllExport int +win32_setmode(int fd, int mode) +{ + return pIOSubSystem->pfnsetmode(fd, mode); +} + +DllExport long +win32_lseek(int fd, long offset, int origin) +{ + return pIOSubSystem->pfnlseek(fd, offset, origin); +} + +DllExport long +win32_tell(int fd) +{ + return pIOSubSystem->pfntell(fd); +} + +DllExport int +win32_open(const char *path, int flag, ...) +{ + va_list ap; + int pmode; + + va_start(ap, flag); + pmode = va_arg(ap, int); + va_end(ap); + + if (stricmp(path, "/dev/null")==0) + return pIOSubSystem->pfnopen("NUL", flag, pmode); + return pIOSubSystem->pfnopen(path,flag,pmode); +} + +DllExport int +win32_close(int fd) +{ + return pIOSubSystem->pfnclose(fd); +} + +DllExport int +win32_eof(int fd) +{ + return pIOSubSystem->pfneof(fd); +} + +DllExport int +win32_dup(int fd) +{ + return pIOSubSystem->pfndup(fd); +} + +DllExport int +win32_dup2(int fd1,int fd2) +{ + return pIOSubSystem->pfndup2(fd1,fd2); +} + +DllExport int +win32_read(int fd, void *buf, unsigned int cnt) +{ + return pIOSubSystem->pfnread(fd, buf, cnt); +} + +DllExport int +win32_write(int fd, const void *buf, unsigned int cnt) +{ + return pIOSubSystem->pfnwrite(fd, buf, cnt); +} + +DllExport int +win32_mkdir(const char *dir, int mode) +{ + return pIOSubSystem->pfnmkdir(dir); /* just ignore mode */ +} + +DllExport int +win32_rmdir(const char *dir) +{ + return pIOSubSystem->pfnrmdir(dir); +} + +DllExport int +win32_chdir(const char *dir) +{ + return pIOSubSystem->pfnchdir(dir); +} + +DllExport int +win32_spawnvp(int mode, const char *cmdname, const char *const *argv) +{ + return pIOSubSystem->pfnspawnvp(mode, cmdname, argv); +} + +DllExport int +win32_execvp(const char *cmdname, const char *const *argv) +{ + return pIOSubSystem->pfnexecvp(cmdname, argv); +} + +DllExport void +win32_perror(const char *str) +{ + pIOSubSystem->pfnperror(str); +} + +DllExport void +win32_setbuf(FILE *pf, char *buf) +{ + pIOSubSystem->pfnsetbuf(pf, buf); +} + +DllExport int +win32_setvbuf(FILE *pf, char *buf, int type, size_t size) +{ + return pIOSubSystem->pfnsetvbuf(pf, buf, type, size); +} + +DllExport int +win32_flushall(void) +{ + return pIOSubSystem->pfnflushall(); +} + +DllExport int +win32_fcloseall(void) +{ + return pIOSubSystem->pfnfcloseall(); +} + +DllExport char* +win32_fgets(char *s, int n, FILE *pf) +{ + return pIOSubSystem->pfnfgets(s, n, pf); +} + +DllExport char* +win32_gets(char *s) +{ + return pIOSubSystem->pfngets(s); +} + +DllExport int +win32_fgetc(FILE *pf) +{ + return pIOSubSystem->pfnfgetc(pf); +} + +DllExport int +win32_putc(int c, FILE *pf) +{ + return pIOSubSystem->pfnputc(c,pf); +} + +DllExport int +win32_puts(const char *s) +{ + return pIOSubSystem->pfnputs(s); +} + +DllExport int +win32_getchar(void) +{ + return pIOSubSystem->pfngetchar(); +} + +DllExport int +win32_putchar(int c) +{ + return pIOSubSystem->pfnputchar(c); +} + +DllExport void* +win32_malloc(size_t size) +{ + return pIOSubSystem->pfnmalloc(size); +} + +DllExport void* +win32_calloc(size_t numitems, size_t size) +{ + return pIOSubSystem->pfncalloc(numitems,size); +} + +DllExport void* +win32_realloc(void *block, size_t size) +{ + return pIOSubSystem->pfnrealloc(block,size); +} + +DllExport void +win32_free(void *block) +{ + pIOSubSystem->pfnfree(block); +} + +int +stolen_open_osfhandle(long handle, int flags) +{ + return pIOSubSystem->pfn_open_osfhandle(handle, flags); +} + +long +stolen_get_osfhandle(int fd) +{ + return pIOSubSystem->pfn_get_osfhandle(fd); +} + +/* + * Extras. + */ + +DllExport int +win32_flock(int fd, int oper) +{ + if (!IsWinNT()) { + croak("flock() unimplemented on this platform"); + return -1; + } + return pIOSubSystem->pfnflock(fd, oper); +} + +static +XS(w32_GetCwd) +{ + dXSARGS; + SV *sv = sv_newmortal(); + /* Make one call with zero size - return value is required size */ + DWORD len = GetCurrentDirectory((DWORD)0,NULL); + SvUPGRADE(sv,SVt_PV); + SvGROW(sv,len); + SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); + /* + * If result != 0 + * then it worked, set PV valid, + * else leave it 'undef' + */ + if (SvCUR(sv)) + SvPOK_on(sv); + EXTEND(sp,1); + ST(0) = sv; + XSRETURN(1); +} + +static +XS(w32_SetCwd) +{ + dXSARGS; + if (items != 1) + croak("usage: Win32::SetCurrentDirectory($cwd)"); + if (SetCurrentDirectory(SvPV(ST(0),na))) + XSRETURN_YES; + + XSRETURN_NO; +} + +static +XS(w32_GetNextAvailDrive) +{ + dXSARGS; + char ix = 'C'; + char root[] = "_:\\"; + while (ix <= 'Z') { + root[0] = ix++; + if (GetDriveType(root) == 1) { + root[2] = '\0'; + XSRETURN_PV(root); + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetLastError) +{ + dXSARGS; + XSRETURN_IV(GetLastError()); +} + +static +XS(w32_LoginName) +{ + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + /* size includes NULL */ + ST(0) = sv_2mortal(newSVpv(name,size-1)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +static +XS(w32_NodeName) +{ + dXSARGS; + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD size = sizeof(name); + if (GetComputerName(name,&size)) { + /* size does NOT include NULL :-( */ + ST(0) = sv_2mortal(newSVpv(name,size)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +static +XS(w32_DomainName) +{ + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + char sid[1024]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, &sid, &sidlen, + dname, &dnamelen, &snu)) { + XSRETURN_PV(dname); /* all that for this */ + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_FsType) +{ + dXSARGS; + char fsname[256]; + DWORD flags, filecomplen; + if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, + &flags, fsname, sizeof(fsname))) { + if (GIMME == G_ARRAY) { + XPUSHs(sv_2mortal(newSVpv(fsname,0))); + XPUSHs(sv_2mortal(newSViv(flags))); + XPUSHs(sv_2mortal(newSViv(filecomplen))); + PUTBACK; + return; + } + XSRETURN_PV(fsname); + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetOSVersion) +{ + dXSARGS; + OSVERSIONINFO osver; + + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if (GetVersionEx(&osver)) { + XPUSHs(newSVpv(osver.szCSDVersion, 0)); + XPUSHs(newSViv(osver.dwMajorVersion)); + XPUSHs(newSViv(osver.dwMinorVersion)); + XPUSHs(newSViv(osver.dwBuildNumber)); + XPUSHs(newSViv(osver.dwPlatformId)); + PUTBACK; + return; + } + XSRETURN_UNDEF; +} + +static +XS(w32_IsWinNT) +{ + dXSARGS; + XSRETURN_IV(IsWinNT()); +} + +static +XS(w32_IsWin95) +{ + dXSARGS; + XSRETURN_IV(IsWin95()); +} + +static +XS(w32_FormatMessage) +{ + dXSARGS; + DWORD source = 0; + char msgbuf[1024]; + + if (items != 1) + croak("usage: Win32::FormatMessage($errno)"); + + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, + &source, SvIV(ST(0)), 0, + msgbuf, sizeof(msgbuf)-1, NULL)) + XSRETURN_PV(msgbuf); + + XSRETURN_UNDEF; +} + +static +XS(w32_Spawn) +{ + dXSARGS; + char *cmd, *args; + PROCESS_INFORMATION stProcInfo; + STARTUPINFO stStartInfo; + BOOL bSuccess = FALSE; + + if(items != 3) + croak("usage: Win32::Spawn($cmdName, $args, $PID)"); + + cmd = SvPV(ST(0),na); + args = SvPV(ST(1), na); + + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ + stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ + stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ + stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ + + if(CreateProcess( + cmd, /* Image path */ + args, /* Arguments for command line */ + NULL, /* Default process security */ + NULL, /* Default thread security */ + FALSE, /* Must be TRUE to use std handles */ + NORMAL_PRIORITY_CLASS, /* No special scheduling */ + NULL, /* Inherit our environment block */ + NULL, /* Inherit our currrent directory */ + &stStartInfo, /* -> Startup info */ + &stProcInfo)) /* <- Process info (if OK) */ + { + CloseHandle(stProcInfo.hThread);/* library source code does this. */ + sv_setiv(ST(2), stProcInfo.dwProcessId); + bSuccess = TRUE; + } + XSRETURN_IV(bSuccess); +} + +static +XS(w32_GetTickCount) +{ + dXSARGS; + XSRETURN_IV(GetTickCount()); +} + +static +XS(w32_GetShortPathName) +{ + dXSARGS; + SV *shortpath; + DWORD len; + + if(items != 1) + croak("usage: Win32::GetShortPathName($longPathName)"); + + shortpath = sv_mortalcopy(ST(0)); + SvUPGRADE(shortpath, SVt_PV); + /* src == target is allowed */ + do { + len = GetShortPathName(SvPVX(shortpath), + SvPVX(shortpath), + SvLEN(shortpath)); + } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1)); + if (len) { + SvCUR_set(shortpath,len); + ST(0) = shortpath; + } + else + ST(0) = &sv_undef; + XSRETURN(1); +} + +void +init_os_extras() +{ + char *file = __FILE__; + dXSUB_SYS; + + /* XXX should be removed after checking with Nick */ + newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); + + /* these names are Activeware compatible */ + newXS("Win32::GetCwd", w32_GetCwd, file); + newXS("Win32::SetCwd", w32_SetCwd, file); + newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); + newXS("Win32::GetLastError", w32_GetLastError, file); + newXS("Win32::LoginName", w32_LoginName, file); + newXS("Win32::NodeName", w32_NodeName, file); + newXS("Win32::DomainName", w32_DomainName, file); + newXS("Win32::FsType", w32_FsType, file); + newXS("Win32::GetOSVersion", w32_GetOSVersion, file); + newXS("Win32::IsWinNT", w32_IsWinNT, file); + newXS("Win32::IsWin95", w32_IsWin95, file); + newXS("Win32::FormatMessage", w32_FormatMessage, file); + newXS("Win32::Spawn", w32_Spawn, file); + newXS("Win32::GetTickCount", w32_GetTickCount, file); + newXS("Win32::GetShortPathName", w32_GetShortPathName, file); + + /* XXX Bloat Alert! The following Activeware preloads really + * ought to be part of Win32::Sys::*, so they're not included + * here. + */ + /* LookupAccountName + * LookupAccountSID + * InitiateSystemShutdown + * AbortSystemShutdown + * ExpandEnvrironmentStrings + */ +} + +void +Perl_win32_init(int *argcp, char ***argvp) +{ + /* Disable floating point errors, Perl will trap the ones we + * care about. VC++ RTL defaults to switching these off + * already, but the Borland RTL doesn't. Since we don't + * want to be at the vendor's whim on the default, we set + * it explicitly here. + */ +#if !defined(_ALPHA_) + _control87(MCW_EM, MCW_EM); +#endif +} diff --git a/gnu/usr.bin/perl/win32/win32.h b/gnu/usr.bin/perl/win32/win32.h new file mode 100644 index 00000000000..dc069ba366c --- /dev/null +++ b/gnu/usr.bin/perl/win32/win32.h @@ -0,0 +1,154 @@ +/* WIN32.H + * + * (c) 1995 Microsoft Corporation. All rights reserved. + * Developed by hip communications inc., http://info.hip.com/info/ + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + */ +#ifndef _INC_WIN32_PERL5 +#define _INC_WIN32_PERL5 + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> + +#ifdef WIN32_LEAN_AND_MEAN /* C file is NOT a Perl5 original. */ +#define CONTEXT PERL_CONTEXT /* Avoid conflict of CONTEXT defs. */ +#define index strchr /* Why 'index'? */ +#endif /*WIN32_LEAN_AND_MEAN */ + +#include <dirent.h> +#include <io.h> +#include <process.h> +#include <stdio.h> +#include <direct.h> + +/* For UNIX compatibility. */ + +#ifdef __BORLANDC__ + +#define _access access +#define _chdir chdir +#include <sys/types.h> + +#ifndef DllMain +#define DllMain DllEntryPoint +#endif + +#pragma warn -ccc +#pragma warn -rch +#pragma warn -sig +#pragma warn -pia +#pragma warn -par +#pragma warn -aus +#pragma warn -use +#pragma warn -csu +#pragma warn -pro + +#else + +typedef long uid_t; +typedef long gid_t; + +#endif + +extern uid_t getuid(void); +extern gid_t getgid(void); +extern uid_t geteuid(void); +extern gid_t getegid(void); +extern int setuid(uid_t uid); +extern int setgid(gid_t gid); + +extern int kill(int pid, int sig); + +extern char *staticlinkmodules[]; + +/* if USE_WIN32_RTL_ENV is not defined, Perl uses direct Win32 calls + * to read the environment, bypassing the runtime's (usually broken) + * facilities for accessing the same. See note in util.c/my_setenv(). + */ +/*#define USE_WIN32_RTL_ENV */ + +#ifndef USE_WIN32_RTL_ENV +#include <stdlib.h> +#ifndef EXT +#include "EXTERN.h" +#endif +#undef getenv +#define getenv win32_getenv +EXT char *win32_getenv(const char *name); +#endif + +EXT void Perl_win32_init(int *argcp, char ***argvp); + +#define USE_SOCKETS_AS_HANDLES +#ifndef USE_SOCKETS_AS_HANDLES +extern FILE *myfdopen(int, char *); + +#undef fdopen +#define fdopen myfdopen +#endif /* USE_SOCKETS_AS_HANDLES */ + +#define STANDARD_C 1 /* Perl5 likes standard C. */ +#define DOSISH 1 /* Take advantage of DOSish code in Perl5. */ + +#define OP_BINARY O_BINARY /* Mistake in in pp_sys.c. */ + +#undef pipe +#define pipe(fd) win32_pipe((fd), 512, O_BINARY) /* the pipe call is a bit different */ + +#undef pause +#define pause() sleep((32767L << 16) + 32767) + + +#undef times +#define times mytimes + +#undef alarm +#define alarm myalarm + +struct tms { + long tms_utime; + long tms_stime; + long tms_cutime; + long tms_cstime; +}; + +unsigned int sleep(unsigned int); +char *win32PerlLibPath(void); +char *win32SiteLibPath(void); +int mytimes(struct tms *timebuf); +unsigned int myalarm(unsigned int sec); +int do_aspawn(void* really, void** mark, void** arglast); +int do_spawn(char *cmd); +char do_exec(char *cmd); +void init_os_extras(void); + +typedef char * caddr_t; /* In malloc.c (core address). */ + +/* + * Extension Library, only good for VC + */ + +#define DllExport __declspec(dllexport) +#define DllImport __declspec(dllimport) + +/* + * handle socket stuff, assuming socket is always available + */ + +#include <sys/socket.h> +#include <netdb.h> + +#ifdef _MSC_VER +#pragma warning(disable: 4018 4035 4101 4102 4244 4245 4761) +#endif + +int IsWin95(void); +int IsWinNT(void); + +#ifndef VER_PLATFORM_WIN32_WINDOWS /* VC-2.0 headers dont have this */ +#define VER_PLATFORM_WIN32_WINDOWS 1 +#endif + +#endif /* _INC_WIN32_PERL5 */ diff --git a/gnu/usr.bin/perl/win32/win32iop.h b/gnu/usr.bin/perl/win32/win32iop.h new file mode 100644 index 00000000000..4606563d0e8 --- /dev/null +++ b/gnu/usr.bin/perl/win32/win32iop.h @@ -0,0 +1,200 @@ +#ifndef WIN32IOP_H +#define WIN32IOP_H + + +/* + * Make this as close to original stdio as possible. + */ + +/* + * function prototypes for our own win32io layer + */ +EXT int * win32_errno(void); +EXT char *** win32_environ(void); +EXT FILE* win32_stdin(void); +EXT FILE* win32_stdout(void); +EXT FILE* win32_stderr(void); +EXT int win32_ferror(FILE *fp); +EXT int win32_feof(FILE *fp); +EXT char* win32_strerror(int e); + +EXT int win32_fprintf(FILE *pf, const char *format, ...); +EXT int win32_printf(const char *format, ...); +EXT int win32_vfprintf(FILE *pf, const char *format, va_list arg); +EXT int win32_vprintf(const char *format, va_list arg); +EXT size_t win32_fread(void *buf, size_t size, size_t count, FILE *pf); +EXT size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf); +EXT FILE* win32_fopen(const char *path, const char *mode); +EXT FILE* win32_fdopen(int fh, const char *mode); +EXT FILE* win32_freopen(const char *path, const char *mode, FILE *pf); +EXT int win32_fclose(FILE *pf); +EXT int win32_fputs(const char *s,FILE *pf); +EXT int win32_fputc(int c,FILE *pf); +EXT int win32_ungetc(int c,FILE *pf); +EXT int win32_getc(FILE *pf); +EXT int win32_fileno(FILE *pf); +EXT void win32_clearerr(FILE *pf); +EXT int win32_fflush(FILE *pf); +EXT long win32_ftell(FILE *pf); +EXT int win32_fseek(FILE *pf,long offset,int origin); +EXT int win32_fgetpos(FILE *pf,fpos_t *p); +EXT int win32_fsetpos(FILE *pf,const fpos_t *p); +EXT void win32_rewind(FILE *pf); +EXT FILE* win32_tmpfile(void); +EXT void win32_abort(void); +EXT int win32_fstat(int fd,struct stat *bufptr); +EXT int win32_stat(const char *name,struct stat *bufptr); +EXT int win32_pipe( int *phandles, unsigned int psize, int textmode ); +EXT FILE* win32_popen( const char *command, const char *mode ); +EXT int win32_pclose( FILE *pf); +EXT int win32_setmode( int fd, int mode); +EXT long win32_lseek( int fd, long offset, int origin); +EXT long win32_tell( int fd); +EXT int win32_dup( int fd); +EXT int win32_dup2(int h1, int h2); +EXT int win32_open(const char *path, int oflag,...); +EXT int win32_close(int fd); +EXT int win32_eof(int fd); +EXT int win32_read(int fd, void *buf, unsigned int cnt); +EXT int win32_write(int fd, const void *buf, unsigned int cnt); +EXT int win32_spawnvp(int mode, const char *cmdname, + const char *const *argv); +EXT int win32_mkdir(const char *dir, int mode); +EXT int win32_rmdir(const char *dir); +EXT int win32_chdir(const char *dir); +EXT int win32_flock(int fd, int oper); +EXT int win32_execvp(const char *cmdname, const char *const *argv); +EXT void win32_perror(const char *str); +EXT void win32_setbuf(FILE *pf, char *buf); +EXT int win32_setvbuf(FILE *pf, char *buf, int type, size_t size); +EXT int win32_flushall(void); +EXT int win32_fcloseall(void); +EXT char* win32_fgets(char *s, int n, FILE *pf); +EXT char* win32_gets(char *s); +EXT int win32_fgetc(FILE *pf); +EXT int win32_putc(int c, FILE *pf); +EXT int win32_puts(const char *s); +EXT int win32_getchar(void); +EXT int win32_putchar(int c); +EXT void* win32_malloc(size_t size); +EXT void* win32_calloc(size_t numitems, size_t size); +EXT void* win32_realloc(void *block, size_t size); +EXT void win32_free(void *block); + +/* + * these two are win32 specific but still io related + */ +int stolen_open_osfhandle(long handle, int flags); +long stolen_get_osfhandle(int fd); + +/* + * defines for flock emulation + */ +#define LOCK_SH 1 +#define LOCK_EX 2 +#define LOCK_NB 4 +#define LOCK_UN 8 + +#include <win32io.h> /* pull in the io sub system structure */ + +EXT PWIN32_IOSUBSYSTEM SetIOSubSystem(void *piosubsystem); +EXT PWIN32_IOSUBSYSTEM GetIOSubSystem(void); + +/* + * the following six(6) is #define in stdio.h + */ +#ifndef WIN32IO_IS_STDIO +#undef errno +#undef environ +#undef stderr +#undef stdin +#undef stdout +#undef ferror +#undef feof + +#ifdef __BORLANDC__ +#undef ungetc +#undef getc +#undef putc +#undef getchar +#undef putchar +#undef fileno +#endif + +#define stderr win32_stderr() +#define stdout win32_stdout() +#define stdin win32_stdin() +#define feof(f) win32_feof(f) +#define ferror(f) win32_ferror(f) +#define errno (*win32_errno()) +#define environ (*win32_environ()) +#define strerror win32_strerror + +/* + * redirect to our own version + */ +#define fprintf win32_fprintf +#define vfprintf win32_vfprintf +#define printf win32_printf +#define vprintf win32_vprintf +#define fread(buf,size,count,f) win32_fread(buf,size,count,f) +#define fwrite(buf,size,count,f) win32_fwrite(buf,size,count,f) +#define fopen win32_fopen +#define fdopen win32_fdopen +#define freopen win32_freopen +#define fclose(f) win32_fclose(f) +#define fputs(s,f) win32_fputs(s,f) +#define fputc(c,f) win32_fputc(c,f) +#define ungetc(c,f) win32_ungetc(c,f) +#define getc(f) win32_getc(f) +#define fileno(f) win32_fileno(f) +#define clearerr(f) win32_clearerr(f) +#define fflush(f) win32_fflush(f) +#define ftell(f) win32_ftell(f) +#define fseek(f,o,w) win32_fseek(f,o,w) +#define fgetpos(f,p) win32_fgetpos(f,p) +#define fsetpos(f,p) win32_fsetpos(f,p) +#define rewind(f) win32_rewind(f) +#define tmpfile() win32_tmpfile() +#define abort() win32_abort() +#define fstat(fd,bufptr) win32_fstat(fd,bufptr) +#define stat(pth,bufptr) win32_stat(pth,bufptr) +#define setmode(fd,mode) win32_setmode(fd,mode) +#define lseek(fd,offset,orig) win32_lseek(fd,offset,orig) +#define tell(fd) win32_tell(fd) +#define dup(fd) win32_dup(fd) +#define dup2(fd1,fd2) win32_dup2(fd1,fd2) +#define open win32_open +#define close(fd) win32_close(fd) +#define eof(fd) win32_eof(fd) +#define read(fd,b,s) win32_read(fd,b,s) +#define write(fd,b,s) win32_write(fd,b,s) +#define _open_osfhandle stolen_open_osfhandle +#define _get_osfhandle stolen_get_osfhandle +#define spawnvp win32_spawnvp +#define mkdir win32_mkdir +#define rmdir win32_rmdir +#define chdir win32_chdir +#define flock(fd,o) win32_flock(fd,o) +#define execvp win32_execvp +#define perror win32_perror +#define setbuf win32_setbuf +#define setvbuf win32_setvbuf +#define flushall win32_flushall +#define fcloseall win32_fcloseall +#define fgets win32_fgets +#define gets win32_gets +#define fgetc win32_fgetc +#define putc win32_putc +#define puts win32_puts +#define getchar win32_getchar +#define putchar win32_putchar +#define fscanf (GetIOSubSystem()->pfnfscanf) +#define scanf (GetIOSubSystem()->pfnscanf) +#define malloc win32_malloc +#define calloc win32_calloc +#define realloc win32_realloc +#define free win32_free +#endif /* WIN32IO_IS_STDIO */ + +#endif /* WIN32IOP_H */ diff --git a/gnu/usr.bin/perl/win32/win32sck.c b/gnu/usr.bin/perl/win32/win32sck.c new file mode 100644 index 00000000000..3653fc8b884 --- /dev/null +++ b/gnu/usr.bin/perl/win32/win32sck.c @@ -0,0 +1,726 @@ +/* NTSock.C + * + * (c) 1995 Microsoft Corporation. All rights reserved. + * Developed by hip communications inc., http://info.hip.com/info/ + * Portions (c) 1993 Intergraph Corporation. All rights reserved. + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + */ + +#include <windows.h> +#define WIN32_LEAN_AND_MEAN +#include "EXTERN.h" +#include "perl.h" +#include <sys/socket.h> +#include <fcntl.h> +#include <sys/stat.h> +#include <assert.h> + +#define CROAK croak + +#ifdef USE_SOCKETS_AS_HANDLES +/* thanks to Beverly Brown (beverly@datacube.com) */ + +#define OPEN_SOCKET(x) _open_osfhandle(x,O_RDWR|O_BINARY) +#define TO_SOCKET(x) _get_osfhandle(x) + +#else + +# define OPEN_SOCKET(x) (x) +# define TO_SOCKET(x) (x) + +#endif /* USE_SOCKETS_AS_HANDLES */ + +static struct servent* win32_savecopyservent(struct servent*d, + struct servent*s, + const char *proto); +#define SOCKETAPI PASCAL + +typedef SOCKET (SOCKETAPI *LPSOCKACCEPT)(SOCKET, struct sockaddr *, int *); +typedef int (SOCKETAPI *LPSOCKBIND)(SOCKET, const struct sockaddr *, int); +typedef int (SOCKETAPI *LPSOCKCLOSESOCKET)(SOCKET); +typedef int (SOCKETAPI *LPSOCKCONNECT)(SOCKET, const struct sockaddr *, int); +typedef int (SOCKETAPI *LPSOCKIOCTLSOCKET)(SOCKET, long, u_long *); +typedef int (SOCKETAPI *LPSOCKGETPEERNAME)(SOCKET, struct sockaddr *, int *); +typedef int (SOCKETAPI *LPSOCKGETSOCKNAME)(SOCKET, struct sockaddr *, int *); +typedef int (SOCKETAPI *LPSOCKGETSOCKOPT)(SOCKET, int, int, char *, int *); +typedef u_long (SOCKETAPI *LPSOCKHTONL)(u_long); +typedef u_short (SOCKETAPI *LPSOCKHTONS)(u_short); +typedef int (SOCKETAPI *LPSOCKLISTEN)(SOCKET, int); +typedef u_long (SOCKETAPI *LPSOCKNTOHL)(u_long); +typedef u_short (SOCKETAPI *LPSOCKNTOHS)(u_short); +typedef int (SOCKETAPI *LPSOCKRECV)(SOCKET, char *, int, int); +typedef int (SOCKETAPI *LPSOCKRECVFROM)(SOCKET, char *, int, int, struct sockaddr *, int *); +typedef int (SOCKETAPI *LPSOCKSELECT)(int, fd_set *, fd_set *, fd_set *, const struct timeval *); +typedef int (SOCKETAPI *LPSOCKSEND)(SOCKET, const char *, int, int); +typedef int (SOCKETAPI *LPSOCKSENDTO)(SOCKET, const char *, int, int, const struct sockaddr *, int); +typedef int (SOCKETAPI *LPSOCKSETSOCKOPT)(SOCKET, int, int, const char *, int); +typedef int (SOCKETAPI *LPSOCKSHUTDOWN)(SOCKET, int); +typedef SOCKET (SOCKETAPI *LPSOCKSOCKET)(int, int, int); +typedef char FAR *(SOCKETAPI *LPSOCKINETNTOA)(struct in_addr in); +typedef unsigned long (SOCKETAPI *LPSOCKINETADDR)(const char FAR * cp); + + +/* Database function prototypes */ +typedef struct hostent *(SOCKETAPI *LPSOCKGETHOSTBYADDR)(const char *, int, int); +typedef struct hostent *(SOCKETAPI *LPSOCKGETHOSTBYNAME)(const char *); +typedef int (SOCKETAPI *LPSOCKGETHOSTNAME)(char *, int); +typedef struct servent *(SOCKETAPI *LPSOCKGETSERVBYPORT)(int, const char *); +typedef struct servent *(SOCKETAPI *LPSOCKGETSERVBYNAME)(const char *, const char *); +typedef struct protoent *(SOCKETAPI *LPSOCKGETPROTOBYNUMBER)(int); +typedef struct protoent *(SOCKETAPI *LPSOCKGETPROTOBYNAME)(const char *); + +/* Microsoft Windows Extension function prototypes */ +typedef int (SOCKETAPI *LPSOCKWSASTARTUP)(unsigned short, LPWSADATA); +typedef int (SOCKETAPI *LPSOCKWSACLEANUP)(void); +typedef int (SOCKETAPI *LPSOCKWSAGETLASTERROR)(void); +typedef int (SOCKETAPI *LPWSAFDIsSet)(SOCKET, fd_set *); + +static HINSTANCE hWinSockDll = 0; +/* extern CRITICAL_SECTION csSock; */ + +static LPSOCKACCEPT paccept = 0; +static LPSOCKBIND pbind = 0; +static LPSOCKCLOSESOCKET pclosesocket = 0; +static LPSOCKCONNECT pconnect = 0; +static LPSOCKIOCTLSOCKET pioctlsocket = 0; +static LPSOCKGETPEERNAME pgetpeername = 0; +static LPSOCKGETSOCKNAME pgetsockname = 0; +static LPSOCKGETSOCKOPT pgetsockopt = 0; +static LPSOCKHTONL phtonl = 0; +static LPSOCKHTONS phtons = 0; +static LPSOCKLISTEN plisten = 0; +static LPSOCKNTOHL pntohl = 0; +static LPSOCKNTOHS pntohs = 0; +static LPSOCKRECV precv = 0; +static LPSOCKRECVFROM precvfrom = 0; +static LPSOCKSELECT pselect = 0; +static LPSOCKSEND psend = 0; +static LPSOCKSENDTO psendto = 0; +static LPSOCKSETSOCKOPT psetsockopt = 0; +static LPSOCKSHUTDOWN pshutdown = 0; +static LPSOCKSOCKET psocket = 0; +static LPSOCKGETHOSTBYADDR pgethostbyaddr = 0; +static LPSOCKGETHOSTBYNAME pgethostbyname = 0; +static LPSOCKGETHOSTNAME pgethostname = 0; +static LPSOCKGETSERVBYPORT pgetservbyport = 0; +static LPSOCKGETSERVBYNAME pgetservbyname = 0; +static LPSOCKGETPROTOBYNUMBER pgetprotobynumber = 0; +static LPSOCKGETPROTOBYNAME pgetprotobyname = 0; +static LPSOCKWSASTARTUP pWSAStartup = 0; +static LPSOCKWSACLEANUP pWSACleanup = 0; +static LPSOCKWSAGETLASTERROR pWSAGetLastError = 0; +static LPWSAFDIsSet pWSAFDIsSet = 0; +static LPSOCKINETNTOA pinet_ntoa = 0; +static LPSOCKINETADDR pinet_addr = 0; + +__declspec(thread) struct servent myservent; + + +void * +GetAddress(HINSTANCE hInstance, char *lpFunctionName) +{ + FARPROC proc = GetProcAddress(hInstance, lpFunctionName); + if(proc == 0) + CROAK("Unable to get address of %s in WSock32.dll", lpFunctionName); + return proc; +} + +void +LoadWinSock(void) +{ +/* EnterCriticalSection(&csSock); */ + if(hWinSockDll == NULL) { + HINSTANCE hLib = LoadLibrary("WSock32.DLL"); + if(hLib == NULL) + CROAK("Could not load WSock32.dll\n"); + + paccept = (LPSOCKACCEPT)GetAddress(hLib, "accept"); + pbind = (LPSOCKBIND)GetAddress(hLib, "bind"); + pclosesocket = (LPSOCKCLOSESOCKET)GetAddress(hLib, "closesocket"); + pconnect = (LPSOCKCONNECT)GetAddress(hLib, "connect"); + pioctlsocket = (LPSOCKIOCTLSOCKET)GetAddress(hLib, "ioctlsocket"); + pgetpeername = (LPSOCKGETPEERNAME)GetAddress(hLib, "getpeername"); + pgetsockname = (LPSOCKGETSOCKNAME)GetAddress(hLib, "getsockname"); + pgetsockopt = (LPSOCKGETSOCKOPT)GetAddress(hLib, "getsockopt"); + phtonl = (LPSOCKHTONL)GetAddress(hLib, "htonl"); + phtons = (LPSOCKHTONS)GetAddress(hLib, "htons"); + plisten = (LPSOCKLISTEN)GetAddress(hLib, "listen"); + pntohl = (LPSOCKNTOHL)GetAddress(hLib, "ntohl"); + pntohs = (LPSOCKNTOHS)GetAddress(hLib, "ntohs"); + precv = (LPSOCKRECV)GetAddress(hLib, "recv"); + precvfrom = (LPSOCKRECVFROM)GetAddress(hLib, "recvfrom"); + pselect = (LPSOCKSELECT)GetAddress(hLib, "select"); + psend = (LPSOCKSEND)GetAddress(hLib, "send"); + psendto = (LPSOCKSENDTO)GetAddress(hLib, "sendto"); + psetsockopt = (LPSOCKSETSOCKOPT)GetAddress(hLib, "setsockopt"); + pshutdown = (LPSOCKSHUTDOWN)GetAddress(hLib, "shutdown"); + psocket = (LPSOCKSOCKET)GetAddress(hLib, "socket"); + pgethostbyaddr = (LPSOCKGETHOSTBYADDR)GetAddress(hLib, "gethostbyaddr"); + pgethostbyname = (LPSOCKGETHOSTBYNAME)GetAddress(hLib, "gethostbyname"); + pgethostname = (LPSOCKGETHOSTNAME)GetAddress(hLib, "gethostname"); + pgetservbyport = (LPSOCKGETSERVBYPORT)GetAddress(hLib, "getservbyport"); + pgetservbyname = (LPSOCKGETSERVBYNAME)GetAddress(hLib, "getservbyname"); + pgetprotobynumber = (LPSOCKGETPROTOBYNUMBER)GetAddress(hLib, "getprotobynumber"); + pgetprotobyname = (LPSOCKGETPROTOBYNAME)GetAddress(hLib, "getprotobyname"); + pWSAStartup = (LPSOCKWSASTARTUP)GetAddress(hLib, "WSAStartup"); + pWSACleanup = (LPSOCKWSACLEANUP)GetAddress(hLib, "WSACleanup"); + pWSAGetLastError = (LPSOCKWSAGETLASTERROR)GetAddress(hLib, "WSAGetLastError"); + pWSAFDIsSet = (LPWSAFDIsSet)GetAddress(hLib, "__WSAFDIsSet"); + pinet_addr = (LPSOCKINETADDR)GetAddress(hLib,"inet_addr"); + pinet_ntoa = (LPSOCKINETNTOA)GetAddress(hLib,"inet_ntoa"); + + hWinSockDll = hLib; + } +/* LeaveCriticalSection(&csSock); */ +} + +void +EndSockets(void) +{ + if(hWinSockDll != NULL) { + pWSACleanup(); + FreeLibrary(hWinSockDll); + } + hWinSockDll = NULL; +} + +void +StartSockets(void) +{ + unsigned short version; + WSADATA retdata; + int ret; + int iSockOpt = SO_SYNCHRONOUS_NONALERT; + + LoadWinSock(); + /* + * initalize the winsock interface and insure that it is + * cleaned up at exit. + */ + version = 0x101; + if(ret = pWSAStartup(version, &retdata)) + CROAK("Unable to locate winsock library!\n"); + if(retdata.wVersion != version) + CROAK("Could not find version 1.1 of winsock dll\n"); + + /* atexit((void (*)(void)) EndSockets); */ + +#ifdef USE_SOCKETS_AS_HANDLES + /* + * Enable the use of sockets as filehandles + */ + psetsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *)&iSockOpt, sizeof(iSockOpt)); +#endif /* USE_SOCKETS_AS_HANDLES */ +} + + +#ifndef USE_SOCKETS_AS_HANDLES +FILE * +myfdopen(int fd, char *mode) +{ + FILE *fp; + char sockbuf[256]; + int optlen = sizeof(sockbuf); + int retval; + + if (hWinSockDll == 0) + return(fdopen(fd, mode)); + + retval = pgetsockopt((SOCKET)fd, SOL_SOCKET, SO_TYPE, sockbuf, &optlen); + if(retval == SOCKET_ERROR && pWSAGetLastError() == WSAENOTSOCK) { + return(fdopen(fd, mode)); + } + + /* + * If we get here, then fd is actually a socket. + */ + Newz(1310, fp, 1, FILE); + if(fp == NULL) { + errno = ENOMEM; + return NULL; + } + + fp->_file = fd; + if(*mode == 'r') + fp->_flag = _IOREAD; + else + fp->_flag = _IOWRT; + + return fp; +} +#endif /* USE_SOCKETS_AS_HANDLES */ + + +u_long +win32_htonl(u_long hostlong) +{ + if(hWinSockDll == 0) + StartSockets(); + + return phtonl(hostlong); +} + +u_short +win32_htons(u_short hostshort) +{ + if(hWinSockDll == 0) + StartSockets(); + + return phtons(hostshort); +} + +u_long +win32_ntohl(u_long netlong) +{ + if(hWinSockDll == 0) + StartSockets(); + + return pntohl(netlong); +} + +u_short +win32_ntohs(u_short netshort) +{ + if(hWinSockDll == 0) + StartSockets(); + + return pntohs(netshort); +} + + +#define SOCKET_TEST(x, y) if(hWinSockDll == 0) StartSockets();\ + if((x) == (y)) errno = pWSAGetLastError() + +#define SOCKET_TEST_ERROR(x) SOCKET_TEST(x, SOCKET_ERROR) + +SOCKET +win32_accept(SOCKET s, struct sockaddr *addr, int *addrlen) +{ + SOCKET r; + + SOCKET_TEST((r = paccept(TO_SOCKET(s), addr, addrlen)), INVALID_SOCKET); + return OPEN_SOCKET(r); +} + +int +win32_bind(SOCKET s, const struct sockaddr *addr, int addrlen) +{ + int r; + + SOCKET_TEST_ERROR(r = pbind(TO_SOCKET(s), addr, addrlen)); + return r; +} + +int +win32_connect(SOCKET s, const struct sockaddr *addr, int addrlen) +{ + int r; + + SOCKET_TEST_ERROR(r = pconnect(TO_SOCKET(s), addr, addrlen)); + return r; +} + + +int +win32_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen) +{ + int r; + + SOCKET_TEST_ERROR(r = pgetpeername(TO_SOCKET(s), addr, addrlen)); + return r; +} + +int +win32_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen) +{ + int r; + + SOCKET_TEST_ERROR(r = pgetsockname(TO_SOCKET(s), addr, addrlen)); + return r; +} + +int +win32_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen) +{ + int r; + + SOCKET_TEST_ERROR(r = pgetsockopt(TO_SOCKET(s), level, optname, optval, optlen)); + return r; +} + +int +win32_ioctlsocket(SOCKET s, long cmd, u_long *argp) +{ + int r; + + SOCKET_TEST_ERROR(r = pioctlsocket(TO_SOCKET(s), cmd, argp)); + return r; +} + +int +win32_listen(SOCKET s, int backlog) +{ + int r; + + SOCKET_TEST_ERROR(r = plisten(TO_SOCKET(s), backlog)); + return r; +} + +int +win32_recv(SOCKET s, char *buf, int len, int flags) +{ + int r; + + SOCKET_TEST_ERROR(r = precv(TO_SOCKET(s), buf, len, flags)); + return r; +} + +int +win32_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int *fromlen) +{ + int r; + + SOCKET_TEST_ERROR(r = precvfrom(TO_SOCKET(s), buf, len, flags, from, fromlen)); + return r; +} + +/* select contributed by Vincent R. Slyngstad (vrs@ibeam.intel.com) */ +int +win32_select(int nfds, int* rd, int* wr, int* ex, const struct timeval* timeout) +{ + long r; + int dummy = 0; + int i, fd, bit, offset; + FD_SET nrd, nwr, nex,*prd,*pwr,*pex; + + if (!rd) + rd = &dummy, prd = NULL; + else + prd = &nrd; + if (!wr) + wr = &dummy, pwr = NULL; + else + pwr = &nwr; + if (!ex) + ex = &dummy, pex = NULL; + else + pex = &nex; + + FD_ZERO(&nrd); + FD_ZERO(&nwr); + FD_ZERO(&nex); + for (i = 0; i < nfds; i++) { + fd = TO_SOCKET(i); + bit = 1L<<(i % (sizeof(int)*8)); + offset = i / (sizeof(int)*8); + if (rd[offset] & bit) + FD_SET(fd, &nrd); + if (wr[offset] & bit) + FD_SET(fd, &nwr); + if (ex[offset] & bit) + FD_SET(fd, &nex); + } + + SOCKET_TEST_ERROR(r = pselect(nfds, prd, pwr, pex, timeout)); + + for (i = 0; i < nfds; i++) { + fd = TO_SOCKET(i); + bit = 1L<<(i % (sizeof(int)*8)); + offset = i / (sizeof(int)*8); + if (rd[offset] & bit) { + if (!pWSAFDIsSet(fd, &nrd)) + rd[offset] &= ~bit; + } + if (wr[offset] & bit) { + if (!pWSAFDIsSet(fd, &nwr)) + wr[offset] &= ~bit; + } + if (ex[offset] & bit) { + if (!pWSAFDIsSet(fd, &nex)) + ex[offset] &= ~bit; + } + } + return r; +} + +int +win32_send(SOCKET s, const char *buf, int len, int flags) +{ + int r; + + SOCKET_TEST_ERROR(r = psend(TO_SOCKET(s), buf, len, flags)); + return r; +} + +int +win32_sendto(SOCKET s, const char *buf, int len, int flags, + const struct sockaddr *to, int tolen) +{ + int r; + + SOCKET_TEST_ERROR(r = psendto(TO_SOCKET(s), buf, len, flags, to, tolen)); + return r; +} + +int +win32_setsockopt(SOCKET s, int level, int optname, const char *optval, int optlen) +{ + int r; + + SOCKET_TEST_ERROR(r = psetsockopt(TO_SOCKET(s), level, optname, optval, optlen)); + return r; +} + +int +win32_shutdown(SOCKET s, int how) +{ + int r; + + SOCKET_TEST_ERROR(r = pshutdown(TO_SOCKET(s), how)); + return r; +} + +SOCKET +win32_socket(int af, int type, int protocol) +{ + SOCKET s; + +#ifndef USE_SOCKETS_AS_HANDLES + SOCKET_TEST(s = psocket(af, type, protocol), INVALID_SOCKET); +#else + if(hWinSockDll == 0) + StartSockets(); + + if((s = psocket(af, type, protocol)) == INVALID_SOCKET) + errno = pWSAGetLastError(); + else + s = OPEN_SOCKET(s); +#endif /* USE_SOCKETS_AS_HANDLES */ + + return s; +} + +#undef fclose +int +my_fclose (FILE *pf) +{ + int osf, retval; + if (hWinSockDll == 0) /* No WinSockDLL? */ + return(fclose(pf)); /* Then not a socket. */ + osf = TO_SOCKET(fileno(pf)); /* Get it now before it's gone! */ + retval = fclose(pf); /* Must fclose() before closesocket() */ + if (osf != -1 + && pclosesocket(osf) == SOCKET_ERROR + && WSAGetLastError() != WSAENOTSOCK) + retval = EOF; + return retval; +} + +struct hostent * +win32_gethostbyaddr(const char *addr, int len, int type) +{ + struct hostent *r; + + SOCKET_TEST(r = pgethostbyaddr(addr, len, type), NULL); + return r; +} + +struct hostent * +win32_gethostbyname(const char *name) +{ + struct hostent *r; + + SOCKET_TEST(r = pgethostbyname(name), NULL); + return r; +} + +int +win32_gethostname(char *name, int len) +{ + int r; + + SOCKET_TEST_ERROR(r = pgethostname(name, len)); + return r; +} + +struct protoent * +win32_getprotobyname(const char *name) +{ + struct protoent *r; + + SOCKET_TEST(r = pgetprotobyname(name), NULL); + return r; +} + +struct protoent * +win32_getprotobynumber(int num) +{ + struct protoent *r; + + SOCKET_TEST(r = pgetprotobynumber(num), NULL); + return r; +} + +struct servent * +win32_getservbyname(const char *name, const char *proto) +{ + struct servent *r; + + SOCKET_TEST(r = pgetservbyname(name, proto), NULL); + if (r) { + r = win32_savecopyservent(&myservent, r, proto); + } + return r; +} + +struct servent * +win32_getservbyport(int port, const char *proto) +{ + struct servent *r; + + SOCKET_TEST(r = pgetservbyport(port, proto), NULL); + if (r) { + r = win32_savecopyservent(&myservent, r, proto); + } + return r; +} + +char FAR * +win32_inet_ntoa(struct in_addr in) +{ + if(hWinSockDll == 0) + StartSockets(); + + return pinet_ntoa(in); +} + +unsigned long +win32_inet_addr(const char FAR *cp) +{ + if(hWinSockDll == 0) + StartSockets(); + + return pinet_addr(cp); + +} + +/* + * Networking stubs + */ +#undef CROAK +#define CROAK croak + +void +win32_endhostent() +{ + CROAK("endhostent not implemented!\n"); +} + +void +win32_endnetent() +{ + CROAK("endnetent not implemented!\n"); +} + +void +win32_endprotoent() +{ + CROAK("endprotoent not implemented!\n"); +} + +void +win32_endservent() +{ + CROAK("endservent not implemented!\n"); +} + + +struct netent * +win32_getnetent(void) +{ + CROAK("getnetent not implemented!\n"); + return (struct netent *) NULL; +} + +struct netent * +win32_getnetbyname(char *name) +{ + CROAK("getnetbyname not implemented!\n"); + return (struct netent *)NULL; +} + +struct netent * +win32_getnetbyaddr(long net, int type) +{ + CROAK("getnetbyaddr not implemented!\n"); + return (struct netent *)NULL; +} + +struct protoent * +win32_getprotoent(void) +{ + CROAK("getprotoent not implemented!\n"); + return (struct protoent *) NULL; +} + +struct servent * +win32_getservent(void) +{ + CROAK("getservent not implemented!\n"); + return (struct servent *) NULL; +} + +void +win32_sethostent(int stayopen) +{ + CROAK("sethostent not implemented!\n"); +} + + +void +win32_setnetent(int stayopen) +{ + CROAK("setnetent not implemented!\n"); +} + + +void +win32_setprotoent(int stayopen) +{ + CROAK("setprotoent not implemented!\n"); +} + + +void +win32_setservent(int stayopen) +{ + CROAK("setservent not implemented!\n"); +} + +#define WIN32IO_IS_STDIO +#include <io.h> +#include "win32iop.h" + +static struct servent* +win32_savecopyservent(struct servent*d, struct servent*s, const char *proto) +{ + d->s_name = s->s_name; + d->s_aliases = s->s_aliases; + d->s_port = s->s_port; +#ifndef __BORLANDC__ /* Buggy on Win95 and WinNT-with-Borland-WSOCK */ + if (!IsWin95() && s->s_proto && strlen(s->s_proto)) + d->s_proto = s->s_proto; + else +#endif + if (proto && strlen(proto)) + d->s_proto = (char *)proto; + else + d->s_proto = "tcp"; + + return d; +} + + diff --git a/gnu/usr.bin/perl/x2p/a2p.pod b/gnu/usr.bin/perl/x2p/a2p.pod new file mode 100644 index 00000000000..fa726fb101c --- /dev/null +++ b/gnu/usr.bin/perl/x2p/a2p.pod @@ -0,0 +1,162 @@ +=head1 NAME + +a2p - Awk to Perl translator + +=head1 SYNOPSIS + +B<a2p [options] filename> + +=head1 DESCRIPTION + +I<A2p> takes an awk script specified on the command line (or from +standard input) and produces a comparable I<perl> script on the +standard output. + +=head2 Options + +Options include: + +=over 5 + +=item B<-DE<lt>numberE<gt>> + +sets debugging flags. + +=item B<-FE<lt>characterE<gt>> + +tells a2p that this awk script is always invoked with this B<-F> +switch. + +=item B<-nE<lt>fieldlistE<gt>> + +specifies the names of the input fields if input does not have to be +split into an array. If you were translating an awk script that +processes the password file, you might say: + + a2p -7 -nlogin.password.uid.gid.gcos.shell.home + +Any delimiter can be used to separate the field names. + +=item B<-E<lt>numberE<gt>> + +causes a2p to assume that input will always have that many fields. + +=item B<-o> + +tells a2p to use old awk behavior. For now, the only difference is +that old awk always has a line loop, even if there are no line +actions, whereas new awk does not. + +=back + +=head2 "Considerations" + +A2p cannot do as good a job translating as a human would, but it +usually does pretty well. There are some areas where you may want to +examine the perl script produced and tweak it some. Here are some of +them, in no particular order. + +There is an awk idiom of putting int() around a string expression to +force numeric interpretation, even though the argument is always +integer anyway. This is generally unneeded in perl, but a2p can't +tell if the argument is always going to be integer, so it leaves it +in. You may wish to remove it. + +Perl differentiates numeric comparison from string comparison. Awk +has one operator for both that decides at run time which comparison to +do. A2p does not try to do a complete job of awk emulation at this +point. Instead it guesses which one you want. It's almost always +right, but it can be spoofed. All such guesses are marked with the +comment "C<#???>". You should go through and check them. You might +want to run at least once with the B<-w> switch to perl, which will +warn you if you use == where you should have used eq. + +Perl does not attempt to emulate the behavior of awk in which +nonexistent array elements spring into existence simply by being +referenced. If somehow you are relying on this mechanism to create +null entries for a subsequent for...in, they won't be there in perl. + +If a2p makes a split line that assigns to a list of variables that +looks like (Fld1, Fld2, Fld3...) you may want to rerun a2p using the +B<-n> option mentioned above. This will let you name the fields +throughout the script. If it splits to an array instead, the script +is probably referring to the number of fields somewhere. + +The exit statement in awk doesn't necessarily exit; it goes to the END +block if there is one. Awk scripts that do contortions within the END +block to bypass the block under such circumstances can be simplified +by removing the conditional in the END block and just exiting directly +from the perl script. + +Perl has two kinds of array, numerically-indexed and associative. +Perl associative arrays are called "hashes". Awk arrays are usually +translated to hashes, but if you happen to know that the index is +always going to be numeric you could change the {...} to [...]. +Iteration over a hash is done using the keys() function, but iteration +over an array is NOT. You might need to modify any loop that iterates +over such an array. + +Awk starts by assuming OFMT has the value %.6g. Perl starts by +assuming its equivalent, $#, to have the value %.20g. You'll want to +set $# explicitly if you use the default value of OFMT. + +Near the top of the line loop will be the split operation that is +implicit in the awk script. There are times when you can move this +down past some conditionals that test the entire record so that the +split is not done as often. + +For aesthetic reasons you may wish to change the array base $[ from 1 +back to perl's default of 0, but remember to change all array +subscripts AND all substr() and index() operations to match. + +Cute comments that say "# Here is a workaround because awk is dumb" +are passed through unmodified. + +Awk scripts are often embedded in a shell script that pipes stuff into +and out of awk. Often the shell script wrapper can be incorporated +into the perl script, since perl can start up pipes into and out of +itself, and can do other things that awk can't do by itself. + +Scripts that refer to the special variables RSTART and RLENGTH can +often be simplified by referring to the variables $`, $& and $', as +long as they are within the scope of the pattern match that sets them. + +The produced perl script may have subroutines defined to deal with +awk's semantics regarding getline and print. Since a2p usually picks +correctness over efficiency. it is almost always possible to rewrite +such code to be more efficient by discarding the semantic sugar. + +For efficiency, you may wish to remove the keyword from any return +statement that is the last statement executed in a subroutine. A2p +catches the most common case, but doesn't analyze embedded blocks for +subtler cases. + +ARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n]. A +loop that tries to iterate over ARGV[0] won't find it. + +=head1 ENVIRONMENT + +A2p uses no environment variables. + +=head1 AUTHOR + +Larry Wall E<lt>F<larry@wall.org>E<gt> + +=head1 FILES + +=head1 SEE ALSO + + perl The perl compiler/interpreter + + s2p sed to perl translator + +=head1 DIAGNOSTICS + +=head1 BUGS + +It would be possible to emulate awk's behavior in selecting string +versus numeric operations at run time by inspection of the operands, +but it would be gross and inefficient. Besides, a2p almost always +guesses right. + +Storage for the awk syntax tree is currently static, and can run out. diff --git a/gnu/usr.bin/perl/x2p/proto.h b/gnu/usr.bin/perl/x2p/proto.h new file mode 100644 index 00000000000..85d749616ae --- /dev/null +++ b/gnu/usr.bin/perl/x2p/proto.h @@ -0,0 +1,8 @@ +/* proto.h + * + * Copyright (c) 1991-1997, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ |