Attachment #41172: perl-5.8.3-openwall-1.3-tempfile.patch for bug #66360

    use DB_File ;

    use DB_File ;

    my %hash ;

    my %hash ;

    unlink $filename ;

    unlink $filename ;

    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 

    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 

    use strict ;

    use strict ;

    use DB_File ;

    use DB_File ;

    my %hash ;

    my %hash ;

    unlink $filename ;

    unlink $filename ;

The locking technique went like this. 

The locking technique went like this. 

    $fd = $db->fd;

    $fd = $db->fd;

    open(DB_FH, "+<&=$fd") || die "dup $!";

    open(DB_FH, "+<&=$fd") || die "dup $!";

    flock (DB_FH, LOCK_EX) || die "flock: $!";

    flock (DB_FH, LOCK_EX) || die "flock: $!";

my $testnum = 181;

my $testnum = 181;

my $failed = 0;

my $failed = 0;

foreach my $test (@tests) {

foreach my $test (@tests) {

    my $err = test_splice(@$test);

    my $err = test_splice(@$test);

    if (defined $err) {

    if (defined $err) {

	}

	}

	if ($changes) {

	if ($changes) {

		print OUT $c;

		print OUT $c;

		close(OUT);

		close(OUT);

		close(DIFF);

		close(DIFF);

	} else {

	} else {

		print "Looks OK\n";

		print "Looks OK\n";

	}

	}

	elsif ($^O eq 'os2') {

	elsif ($^O eq 'os2') {

	    require IO::Socket;

	    require IO::Socket;

	      or $@ !~ /not implemented/ or

	      or $@ !~ /not implemented/ or

		$reason = 'compiled without TCP/IP stack v4';

		$reason = 'compiled without TCP/IP stack v4';

	} elsif ($^O =~ m/^(?:qnx|nto|vos)$/ ) {

	} elsif ($^O =~ m/^(?:qnx|nto|vos)$/ ) {

    }

    }

}

}

# Test if we can create the file within the tmp directory

# Test if we can create the file within the tmp directory

if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') {

if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') {

 * Set DBM_BUG_DUPLICATE_FREE in the extension hint file.

 * Set DBM_BUG_DUPLICATE_FREE in the extension hint file.

 */

 */

/* Close the previous dbm, and fail to open a new dbm */

/* Close the previous dbm, and fail to open a new dbm */

#endif

#endif

#include <fcntl.h>

#include <fcntl.h>

uses file descriptors such as those obtained by calling C<POSIX::open>.

uses file descriptors such as those obtained by calling C<POSIX::open>.

The following will determine the maximum length of the longest allowable

The following will determine the maximum length of the longest allowable

	$path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX );

	$path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX );

Returns C<undef> on failure.

Returns C<undef> on failure.

Open a directory for reading.

Open a directory for reading.

	@files = POSIX::readdir( $dir );

	@files = POSIX::readdir( $dir );

	POSIX::closedir( $dir );

	POSIX::closedir( $dir );

Retrieves the value of a configurable limit on a file or directory.

Retrieves the value of a configurable limit on a file or directory.

The following will determine the maximum length of the longest allowable

The following will determine the maximum length of the longest allowable

Returns C<undef> on failure.

Returns C<undef> on failure.

    $proto = getprotobyname('tcp');

    $proto = getprotobyname('tcp');

    socket(Socket_Handle, PF_UNIX, SOCK_STREAM, $proto);

    socket(Socket_Handle, PF_UNIX, SOCK_STREAM, $proto);

    connect(Socket_Handle,$sun);

    connect(Socket_Handle,$sun);

=head1 DESCRIPTION

=head1 DESCRIPTION

	%color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1);

	%color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1);

	printf "Blue is still %lf\n", $colref->{'Blue'};

	printf "Blue is still %lf\n", $colref->{'Blue'};

	$colref2 = dclone(\%color);

	$colref2 = dclone(\%color);

# without changing it, and then I'd always forget to change it before a

# without changing it, and then I'd always forget to change it before a

# release. Sorry, Edward :)

# release. Sorry, Edward :)

sub try_compile_and_link {

sub try_compile_and_link {

    my ($c, %args) = @_;

    my ($c, %args) = @_;

    my ($ok) = 0;

    my ($ok) = 0;

    local(*TMPC);

    local(*TMPC);

    my $obj_ext = $Config{obj_ext} || ".o";

    my $obj_ext = $Config{obj_ext} || ".o";

You may also retrieve cookies that were stored in some external

You may also retrieve cookies that were stored in some external

form using the parse() class method:

form using the parse() class method:

       %cookies = parse CGI::Cookie($COOKIES);

       %cookies = parse CGI::Cookie($COOKIES);

If you are in a mod_perl environment, you can save some overhead by

If you are in a mod_perl environment, you can save some overhead by

require 5.004;

require 5.004;

use Carp 'croak';

use Carp 'croak';

# See the bottom of this file for the POD documentation.  Search for the

# See the bottom of this file for the POD documentation.  Search for the

# string '=head'.

# string '=head'.

# If more accuracy is wanted/needed, Chris Leach sent me this patch...

# If more accuracy is wanted/needed, Chris Leach sent me this patch...

 # > *** /install/perl/live/lib/CPAN.pm-	Wed Sep 24 13:08:48 1997

 # > *** /install/perl/live/lib/CPAN.pm-	Wed Sep 24 13:08:48 1997

 # > ***************

 # > ***************

 # > *** 1562,1567 ****

 # > *** 1562,1567 ****

 # > --- 1562,1580 ----

 # > --- 1562,1580 ----

The Makefile to be produced may be altered by adding arguments of the

The Makefile to be produced may be altered by adding arguments of the

form C<KEY=VALUE>. E.g.

form C<KEY=VALUE>. E.g.

Other interesting targets in the generated Makefile are

Other interesting targets in the generated Makefile are

This is the root directory into which the code will be installed.  It

This is the root directory into which the code will be installed.  It

I<prepends itself to the normal prefix>.  For example, if your code

I<prepends itself to the normal prefix>.  For example, if your code

This is primarily of use for people who repackage Perl modules.

This is primarily of use for people who repackage Perl modules.

NOTE: Due to the nature of make, it is important that you put the trailing

NOTE: Due to the nature of make, it is important that you put the trailing

=item DIR

=item DIR

use strict;

use strict;

use IO::File;

use IO::File;

use ExtUtils::Packlist;

use ExtUtils::Packlist;

use ExtUtils::Installed;

use ExtUtils::Installed;

      $reply =~ /^t\s*/ and do

      $reply =~ /^t\s*/ and do

         {

         {

         my $file = (split(' ', $reply))[1];

         my $file = (split(' ', $reply))[1];

         last CASE;

         last CASE;

         };

         };

      $reply eq 'v' and do

      $reply eq 'v' and do

  $_[0]+1;

  $_[0]+1;

}

}

@files = ($file, "$file.db", "$file.dir", "$file.pag");

@files = ($file, "$file.db", "$file.dir", "$file.pag");

1 while unlink @files;

1 while unlink @files;

print "1..4\n";

print "1..4\n";

1 while unlink $file, "$file.dir", "$file.pag";

1 while unlink $file, "$file.dir", "$file.pag";

tryout('GDBM_File', $file, 1);  # Test 1..4

tryout('GDBM_File', $file, 1);  # Test 1..4

1 while unlink $file, "$file.dir", "$file.pag";

1 while unlink $file, "$file.dir", "$file.pag";

print "1..4\n";

print "1..4\n";

1 while unlink $file, "$file.dir", "$file.pag";

1 while unlink $file, "$file.dir", "$file.pag";

tryout('Memoize::NDBM_File', $file, 1);  # Test 1..4

tryout('Memoize::NDBM_File', $file, 1);  # Test 1..4

1 while unlink $file, "$file.dir", "$file.pag";

1 while unlink $file, "$file.dir", "$file.pag";

print "1..4\n";

print "1..4\n";

1 while unlink $file, "$file.dir", "$file.pag";

1 while unlink $file, "$file.dir", "$file.pag";

tryout('Memoize::SDBM_File', $file, 1);  # Test 1..4

tryout('Memoize::SDBM_File', $file, 1);  # Test 1..4

1 while unlink $file, "$file.dir", "$file.pag";

1 while unlink $file, "$file.dir", "$file.pag";

print "1..4\n";

print "1..4\n";

1 while unlink $file;

1 while unlink $file;

tryout('Memoize::Storable', $file, 1);  # Test 1..4

tryout('Memoize::Storable', $file, 1);  # Test 1..4

1 while unlink $file;

1 while unlink $file;

    sub ps;

    sub ps;

    print ps -ww;

    print ps -ww;

That's maybe too gonzo.  It actually exports an AUTOLOAD to the current

That's maybe too gonzo.  It actually exports an AUTOLOAD to the current

package (and uncovered a bug in Beta 3, by the way).  Maybe the usual

package (and uncovered a bug in Beta 3, by the way).  Maybe the usual

#         dependent upon. These variables MUST be defined using shell syntax.

#         dependent upon. These variables MUST be defined using shell syntax.

#

#

#   Example:

#   Example:

#

#

sub dotsh {

sub dotsh {

   local(@sh) = @_;

   local(@sh) = @_;

      }

      }

   }

   }

   if (length($vars) > 0) {

   if (length($vars) > 0) {

   } else {

   } else {

   }

   }

   while (<_SH_ENV>) {

   while (<_SH_ENV>) {

       chop;

       chop;

       m/^([^=]*)=(.*)/s;

       m/^([^=]*)=(.*)/s;

       $ENV{$1} = $2;

       $ENV{$1} = $2;

   }

   }

   close (_SH_ENV);

   close (_SH_ENV);

   foreach $key (keys(%ENV)) {

   foreach $key (keys(%ENV)) {

       $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;

       $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;

=item * noTTY 

=item * noTTY 

if set, goes in NonStop mode.  On interrupt, if TTY is not set,

if set, goes in NonStop mode.  On interrupt, if TTY is not set,

Term::Rendezvous.  Current variant is to have the name of TTY in this

Term::Rendezvous.  Current variant is to have the name of TTY in this

file.

file.

        else {

        else {

            eval "require Term::Rendezvous;" or die;

            eval "require Term::Rendezvous;" or die;

            # See if we have anything to pass to Term::Rendezvous.

            # See if we have anything to pass to Term::Rendezvous.

            # Rendezvous and get the filehandles.

            # Rendezvous and get the filehandles.

            my $term_rv = new Term::Rendezvous $rv;

            my $term_rv = new Term::Rendezvous $rv;

# I wanted to pipe this into awk, but it fell victim to a known pipe/streams

# I wanted to pipe this into awk, but it fell victim to a known pipe/streams

# bug on my multiprocessor machine.

# bug on my multiprocessor machine.

/bin/awk '\

/bin/awk '\

    / data  univ / { printf "%-20s|%10s|%-6s|%-7s|%s\n",$1,$5,"extern","data","?"} \

    / data  univ / { printf "%-20s|%10s|%-6s|%-7s|%s\n",$1,$5,"extern","data","?"} \

exit 0

exit 0

echo "Creating $RAND.sl...\n"

echo "Creating $RAND.sl...\n"

rm -f $TEMP $RAND.a $RAND.sl

rm -f $TEMP $RAND.a $RAND.sl

input=$1

input=$1

output=$2

output=$2

inputh=`echo $input|sed 's:\.c$:.h:'`

inputh=`echo $input|sed 's:\.c$:.h:'`

if grep '^#ifdef PERL_CORE' $inputh; then

if grep '^#ifdef PERL_CORE' $inputh; then

If your file system supports symbolic links you can build Perl outside

If your file system supports symbolic links you can build Perl outside

of the source directory by

of the source directory by

	sh /path/to/perl/source/Configure -Dmksymlinks ...

	sh /path/to/perl/source/Configure -Dmksymlinks ...

pointing to files in /path/to/perl/source.  The original files are left

pointing to files in /path/to/perl/source.  The original files are left

unaffected.  After Configure has finished you can just say

unaffected.  After Configure has finished you can just say

	make all test

	make all test

=back

=back

If your file system supports symbolic links, you can build Perl outside

If your file system supports symbolic links, you can build Perl outside

of the source directory by

of the source directory by

	sh /path/to/perl/source/Configure -Dmksymlinks ...

	sh /path/to/perl/source/Configure -Dmksymlinks ...

pointing to files in /path/to/perl/source.  The original files are left

pointing to files in /path/to/perl/source.  The original files are left

unaffected.  After Configure has finished, you can just say

unaffected.  After Configure has finished, you can just say

	make all test

	make all test

[561]

[561]

=item *

=item *

    use Fcntl ;

    use Fcntl ;

    my %hash ;

    my %hash ;

    unlink $filename ;

    unlink $filename ;

    my $db = tie(%hash, 'SDBM_File', $filename, O_RDWR|O_CREAT, 0640)

    my $db = tie(%hash, 'SDBM_File', $filename, O_RDWR|O_CREAT, 0640)

    use warnings ;

    use warnings ;

    use DB_File ;

    use DB_File ;

    my %hash ;

    my %hash ;

    unlink $filename ;

    unlink $filename ;

with two methods: C<IN> and C<OUT>.  These should return filehandles to use

with two methods: C<IN> and C<OUT>.  These should return filehandles to use

for debugging input and output correspondingly.  The C<new> method should

for debugging input and output correspondingly.  The C<new> method should

inspect an argument containing the value of C<$ENV{PERLDB_NOTTY}> at

inspect an argument containing the value of C<$ENV{PERLDB_NOTTY}> at

inspected for proper ownership, so security hazards are theoretically

inspected for proper ownership, so security hazards are theoretically

possible.

possible.

	    my $count = 0;

	    my $count = 0;

	    until (defined(fileno(FH)) || $count++ > 100) {

	    until (defined(fileno(FH)) || $count++ > 100) {

		$base_name =~ s/-(\d+)$/"-" . (1 + $1)/e;

		$base_name =~ s/-(\d+)$/"-" . (1 + $1)/e;

		sysopen(FH, $base_name, O_WRONLY|O_EXCL|O_CREAT);

		sysopen(FH, $base_name, O_WRONLY|O_EXCL|O_CREAT);

	    }

	    }

	    if (defined(fileno(FH))

	    if (defined(fileno(FH))

To open a file without blocking, creating if necessary:

To open a file without blocking, creating if necessary:

Be warned that neither creation nor deletion of files is guaranteed to

Be warned that neither creation nor deletion of files is guaranteed to

be an atomic operation over NFS.  That is, two processes might both

be an atomic operation over NFS.  That is, two processes might both

If you check L<perlfunc/open>, you'll see that several of the ways

If you check L<perlfunc/open>, you'll see that several of the ways

to call open() should do the trick.  For example:

to call open() should do the trick.  For example:

    open(STDERR, ">&LOG");

    open(STDERR, ">&LOG");

Or even with a literal numeric descriptor:

Or even with a literal numeric descriptor:

    while (<PH>) { }                            #    plus a read

    while (<PH>) { }                            #    plus a read

To read both a command's STDOUT and its STDERR separately, it's easiest

To read both a command's STDOUT and its STDERR separately, it's easiest

Ordering is important in all these examples.  That's because the shell

Ordering is important in all these examples.  That's because the shell

processes file descriptor redirections in strictly left to right order.

processes file descriptor redirections in strictly left to right order.

sysopen():

sysopen():

    use Fcntl;

    use Fcntl;

=head2 How do I install a module from CPAN?

=head2 How do I install a module from CPAN?

    open(ARTICLE, "caesar <$article |")		# ditto

    open(ARTICLE, "caesar <$article |")		# ditto

	or die "Can't start caesar: $!";

	or die "Can't start caesar: $!";

	or die "Can't start sort: $!";

	or die "Can't start sort: $!";

    # in memory files

    # in memory files

    use strict;

    use strict;

    my ($rendezvous, $line);

    my ($rendezvous, $line);

    socket(SOCK, PF_UNIX, SOCK_STREAM, 0)	|| die "socket: $!";

    socket(SOCK, PF_UNIX, SOCK_STREAM, 0)	|| die "socket: $!";

    connect(SOCK, sockaddr_un($rendezvous))	|| die "connect: $!";

    connect(SOCK, sockaddr_un($rendezvous))	|| die "connect: $!";

    while (defined($line = <SOCK>)) {

    while (defined($line = <SOCK>)) {

    sub spawn;  # forward declaration

    sub spawn;  # forward declaration

    sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

    sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

    my $uaddr = sockaddr_un($NAME);

    my $uaddr = sockaddr_un($NAME);

    my $proto = getprotobyname('tcp');

    my $proto = getprotobyname('tcp');

    sub open {

    sub open {

        my $path = shift ;

        my $path = shift ;

        if ($path !~ m#^/#) {

        if ($path !~ m#^/#) {

                if warnings::enabled();

                if warnings::enabled();

        }

        }

    }

    }

    warn "time to die...";

    warn "time to die...";

    exit;

    exit;

    DESTROYING Subtle=SCALAR(0x8e57c) during global destruction.

    DESTROYING Subtle=SCALAR(0x8e57c) during global destruction.

Notice that "global destruction" bit there?  That's the thread

Notice that "global destruction" bit there?  That's the thread

    $output = `cmd 3>&1 1>&2 2>&3 3>&-`;

    $output = `cmd 3>&1 1>&2 2>&3 3>&-`;

To read both a command's STDOUT and its STDERR separately, it's easiest

To read both a command's STDOUT and its STDERR separately, it's easiest

Using single-quote as a delimiter protects the command from Perl's

Using single-quote as a delimiter protects the command from Perl's

double-quote interpolation, passing it on to the shell instead:

double-quote interpolation, passing it on to the shell instead:

    open(WTMP, "+< /usr/adm/wtmp") 

    open(WTMP, "+< /usr/adm/wtmp") 

        || die "can't open /usr/adm/wtmp: $!";

        || die "can't open /usr/adm/wtmp: $!";

The first one won't create a new file, and the second one will always

The first one won't create a new file, and the second one will always

clobber an old one.  The third one will create a new file if necessary

clobber an old one.  The third one will create a new file if necessary

$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';

$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';

######################################################################

######################################################################

    printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;

    printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;

}

}

$recurse = 1;

$recurse = 1;

if (@ARGV) {

if (@ARGV) {

    }

    }

    elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {

    elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {

	local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;

	local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;

	&system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;

	&system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;

	$ARGV[0] =~ s/\.c$/.s/;

	$ARGV[0] =~ s/\.c$/.s/;

    }

    }

    else {

    else {

	&system("cat @ARGV > $TMP") && exit 1;

	&system("cat @ARGV > $TMP") && exit 1;

	unlink $TMP;

	unlink $TMP;

	$TMP =~ s/\.c$/.s/;

	$TMP =~ s/\.c$/.s/;

	@ARGV = ($TMP);

	@ARGV = ($TMP);

}

}

sub compute_intrinsics {

sub compute_intrinsics {

    open (TMP, ">$TMP") || die "can't open $TMP: $!";

    open (TMP, ">$TMP") || die "can't open $TMP: $!";

    select(TMP);

    select(TMP);

    close TMP;

    close TMP;

    select(STDOUT);

    select(STDOUT);

    while (<PIPE>) {

    while (<PIPE>) {

	chop;

	chop;

	split(' ',$_,2);;

	split(' ',$_,2);;

	$intrinsics{$_[1]} = $template{$_[0]};

	$intrinsics{$_[1]} = $template{$_[0]};

    }

    }

    close(PIPE) || die "couldn't read intrinsics!";

    close(PIPE) || die "couldn't read intrinsics!";

    print STDERR "done\n" if $trace;

    print STDERR "done\n" if $trace;

}

}

print OUT <<'!NO!SUBS!';

print OUT <<'!NO!SUBS!';

use Config;

use Config;

use Getopt::Std;

use Getopt::Std;

use strict;

use strict;

}

}

sub filename {

sub filename {

}

}

sub paraprint {

sub paraprint {