[inseparable changes from patch from perl5.003_23 to perl5.003_24]perl-5.003_24

 CORE LANGUAGE CHANGES

Subject: glob defaults to $_
Date: Mon, 27 Jan 1997 03:09:13 -0500
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: op.c opcode.pl pod/perlfunc.pod t/op/glob.t

    private-msgid: <199701270809.DAA00934@aatma.engin.umich.edu>

Subject: Re: an overloading bug 
Date: Sun, 26 Jan 1997 19:07:45 -0500
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: pod/perldiag.pod pod/perlfunc.pod pp_ctl.c

    private-msgid: <199701270007.TAA26525@aatma.engin.umich.edu>

 CORE PORTABILITY

Subject: Win32 port
From: Gary Ng <71564.1743@compuserve.com>
Files: MANIFEST win32/*

Subject: Amiga files
Date: Sun, 26 Jan 1997 17:42:15 +0100
From: Norbert Pueschel <pueschel@imsdd.meb.uni-bonn.de>
Files: MANIFEST README.amiga hints/amigaos.sh

    private-msgid: <77724712@Armageddon.meb.uni-bonn.de>

 DOCUMENTATION

Subject: perldelta Fcntl enhancement
Date: Sat, 25 Jan 1997 17:05:34 +0200 (EET)
From: Jarkko Hietaniemi <jhi@cc.hut.fi>
Files: pod/perldelta.pod

    private-msgid: <199701251505.RAA22159@alpha.hut.fi>

Subject: Updates to perldelta re: Fcntl, DB_File, Net::Ping
From: Paul Marquess <pmarquess@bfsec.bt.co.uk>
Files: pod/perldelta.pod

Subject: Document restrictions on gv_fetchmethod() and perl_call_sv()
From: Chip Salzenberg <chip@atlantic.net>
Files: pod/perldelta.pod pod/perlguts.pod

Subject: perldiag.pod: No comma allowed after %s
Date: Sat, 25 Jan 1997 17:41:53 +0200 (EET)
From: Jarkko Hietaniemi <Jarkko.Hietaniemi@cc.hut.fi>
Files: pod/perldiag.pod

    private-msgid: <199701251541.RAA04120@alpha.hut.fi>

Subject: perlfunc.pod: localtime
Date: Sat, 25 Jan 1997 18:29:37 +0200 (EET)
From: Jarkko Hietaniemi <jhi@cc.hut.fi>
Files: pod/perlfunc.pod

    private-msgid: <199701251629.SAA08114@alpha.hut.fi>

Subject: perlfunc diff: gmtime
Date: Tue, 28 Jan 1997 14:52:08 +0000
From: Peter Haworth <pmh@edison.ioppublishing.com>
Files: pod/perlfunc.pod

    private-msgid: <32EE1298.7B90@edison.ioppublishing.com>

Subject: Updates to guts
Date: Sun, 26 Jan 1997 19:34:18 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: pod/perlguts.pod

    private-msgid: <199701270034.TAA13177@monk.mps.ohio-state.edu>

 TESTS

Subject: New test op/closure.t
From: Tom Phoenix <rootbeer@teleport.com>
Files: MANIFEST t/op/closure.t

2 files changed, 427 insertions, 2 deletions

diff --git a/t/op/closure.t b/t/op/closure.t
index e69de29bb2..752f30c9c6 100755
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -0,0 +1,417 @@
+#!./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.
+#
+
+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>.
+
+{
+    BEGIN {
+      if (-d 't') {
+	unshift @INC, "lib"
+      } else {
+	unshift @INC, '../lib'
+      }
+    }
+    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++;
+	  }
+
+	  # 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: $!";
+	  }
+	  # Parent process here.
+	  close WRITE;
+	  close WRITE2;
+	  print PERL $code;
+	  close PERL;
+	  $output = join '', <READ>;
+	  $errors = join '', <READ2>;
+	  print $output, $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 %04lX\n",$? if $?;
+	  print "-" x 30, $/ if $debugging;
+
+	}	# End of foreach $within
+      }	# End of foreach $where_declared
+    }	# End of foreach $inner_type
+
+}
diff --git a/t/op/glob.t b/t/op/glob.t
index fce2952968..cc60a17a72 100755
--- a/t/op/glob.t
+++ b/t/op/glob.t
@@ -2,9 +2,9 @@
 
 # $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $
 
-print "1..4\n";
+print "1..6\n";
 
-@ops = <op/*>;
+@oops = @ops = <op/*>;
 
 map { $files{$_}++ } <op/*>;
 map { delete $files{$_} } split /[\s\n]/, `echo op/*`;
@@ -21,3 +21,11 @@ while (<jskdfjskdfj* op/* jskdjfjkosvk*>) {
 print "${not}ok 3\n";
 
 print $/ eq "\n" ? "ok 4\n" : "not ok 4\n";
+
+# test the "glob" operator
+$_ = "op/*";
+@glops = glob $_;
+print "@glops" eq "@oops" ? "ok 5\n" : "not ok 5\n";
+
+@glops = glob;
+print "@glops" eq "@oops" ? "ok 6\n" : "not ok 6\n";