Integrate with Sarathy.

p4raw-id: //depot/cfgperl@5469

18 files changed, 140 insertions, 39 deletions

diff --git a/INSTALL b/INSTALL
index bb0eeb0060..7a3a0c5c11 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1594,10 +1594,8 @@ external program.
 
 On some systems, particularly those with smaller amounts of RAM, some
 of the tests in t/op/pat.t may fail with an "Out of memory" message.
-Specifically, in perl5.004_64, tests 74 and 78 have been reported to
-fail on some systems.  On my SparcStation IPC with 8 MB of RAM, test 78
-will fail if the system is running any other significant tasks at the
-same time.
+For example, on my SparcStation IPC with 12 MB of RAM, in perl5.5.670,
+test 85 will fail if run under either t/TEST or t/harness.
 
 Try stopping other jobs on the system and then running the test by itself:
 
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm
index ecdb039987..0be3ae6765 100644
--- a/lib/AutoSplit.pm
+++ b/lib/AutoSplit.pm
@@ -148,7 +148,7 @@ my $Is_VMS = ($^O eq 'VMS');
 
 # allow checking for valid ': attrlist' attachments
 my $nested;
-$nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x;
+$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
 my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
 my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x;
 
diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 49d167dc0b..ff66b22a7d 100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -249,9 +249,9 @@ foreach $key (keys %input_expr) {
     $input_expr{$key} =~ s/\n+$//;
 }
 
-$bal = qr[(?:(?>[^()]+)|\((?p{ $bal })\))*];	# ()-balanced
+$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*];	# ()-balanced
 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?];		# Optional (SV*) cast
-$size = qr[,\s* (?p{ $bal }) ]x;		# Third arg (to setpvn)
+$size = qr[,\s* (??{ $bal }) ]x;		# Third arg (to setpvn)
 
 foreach $key (keys %output_expr) {
     use re 'eval';
@@ -260,8 +260,8 @@ foreach $key (keys %output_expr) {
       ($output_expr{$key} =~
 	 m[^ \s+ sv_set ( [iunp] ) v (n)? 	# Type, is_setpvn
 	     \s* \( \s* $cast \$arg \s* ,
-	     \s* ( (?p{ $bal }) )		# Set from
-	     ( (?p{ $size }) )?			# Possible sizeof set-from
+	     \s* ( (??{ $bal }) )		# Set from
+	     ( (??{ $size }) )?			# Possible sizeof set-from
 	     \) \s* ; \s* $
 	  ]x);
     $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
@@ -287,11 +287,11 @@ sub check_keyword {
 my ($C_group_rex, $C_arg);
 # Group in C (no support for comments or literals)
 $C_group_rex = qr/ [({\[]
-		   (?: (?> [^()\[\]{}]+ ) | (?p{ $C_group_rex }) )*
+		   (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
 		   [)}\]] /x ;
 # Chunk in C without comma at toplevel (no comments):
 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
-	     |   (?p{ $C_group_rex })
+	     |   (??{ $C_group_rex })
 	     |   " (?: (?> [^\\"]+ )
 		   |   \\.
 		   )* "		# String literal
@@ -1029,8 +1029,8 @@ while (fetch_para()) {
     my %out_vars;
     if ($process_argtypes and $orig_args =~ /\S/) {
 	my $args = "$orig_args ,";
-	if ($args =~ /^( (?p{ $C_arg }) , )* $ /x) {
-	    @args = ($args =~ /\G ( (?p{ $C_arg }) ) , /xg);
+	if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
+	    @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
 	    for ( @args ) {
 		s/^\s+//;
 		s/\s+$//;
diff --git a/lib/SelfLoader.pm b/lib/SelfLoader.pm
index 2aa29303fd..ff441c72dd 100644
--- a/lib/SelfLoader.pm
+++ b/lib/SelfLoader.pm
@@ -11,7 +11,7 @@ my %Cache;      # private cache for all SelfLoader's client packages
 
 # allow checking for valid ': attrlist' attachments
 my $nested;
-$nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x;
+$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
 my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
 my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x;
 
diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index 6d472a9f4a..9902741134 100644
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -95,6 +95,8 @@ sub runtests {
 	$fh->open($test) or print "can't open $test. $!\n";
 	my $first = <$fh>;
 	my $s = $switches;
+	$s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
+	    if exists $ENV{'HARNESS_PERL_SWITCHES'};
 	$s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
 	    if $first =~ /^#!.*\bperl.*-\w*T/;
 	$fh->close or print "can't close $test. $!\n";
@@ -509,6 +511,11 @@ If relative, directory name is with respect to the current directory at
 the moment runtests() was called.  Putting absolute path into 
 C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
 
+The value of C<HARNESS_PERL_SWITCHES> will be prepended to the
+switches used to invoke perl on each test.  For example, setting
+C<HARNESS_PERL_SWITCHES> to "-W" will run all tests with all
+warnings enabled.
+
 Harness sets C<HARNESS_ACTIVE> before executing the individual tests.
 This allows the tests to determine if they are being executed through the
 harness or by any other means.
diff --git a/lib/constant.pm b/lib/constant.pm
index bbfdb78ec4..b4fcd421ac 100644
--- a/lib/constant.pm
+++ b/lib/constant.pm
@@ -35,7 +35,7 @@ sub import {
     my $pkg = caller;
 
     # Normal constant name
-    if ($name =~ /^(?:[A-Z]\w|_[A-Z])\w*\z/ and !$forbidden{$name}) {
+    if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
         # Everything is okay
 
     # Name forced into main, but we're not in main. Fatal.
@@ -58,11 +58,6 @@ sub import {
 	    } elsif ($forced_into_main{$name}) {
 		Carp::carp("Constant name '$name' is " .
 		    "forced into package main::");
-	    } elsif (1 == length $name) {
-		Carp::carp("Constant name '$name' is too short");
-	    } elsif ($name =~ /^_?[a-z\d]/) {
-		Carp::carp("Constant name '$name' should " .
-		    "have an initial capital letter");
 	    } else {
 		# Catch-all - what did I miss? If you get this error,
 		# please let me know what your constant's name was.
diff --git a/pod/perl.pod b/pod/perl.pod
index 0414fa4f29..cb627cdb7a 100644
--- a/pod/perl.pod
+++ b/pod/perl.pod
@@ -35,6 +35,7 @@ sections:
     perlmodlib		Perl modules: how to write and use
     perlmodinstall	Perl modules: how to install from CPAN
     perlform		Perl formats
+    perlunicode		Perl unicode support
     perllocale		Perl locale support
 
     perlreftut		Perl references short introduction
@@ -50,7 +51,8 @@ sections:
     perlipc		Perl interprocess communication
     perlfork		Perl fork() information
     perlthrtut		Perl threads tutorial
-    perldbmfilter	Perl DBM Filters
+    perllexwarn		Perl warnings and their control
+    perldbmfilter	Perl DBM filters
 
     perlcompile		Perl compiler suite intro
     perldebug		Perl debugging
@@ -77,6 +79,15 @@ sections:
     perlhack		Perl hackers guide
     perlhist		Perl history records
 
+    perlamiga		Perl notes for Amiga
+    perlcygwin		Perl notes for Cygwin
+    perldos		Perl notes for DOS
+    perlhpux		Perl notes for HP-UX
+    perlos2		Perl notes for OS/2
+    perlos390		Perl notes for OS/390
+    perlvms		Perl notes for VMS
+    perlwin32		Perl notes for Windows
+
 (If you're intending to read these straight through for the first time,
 the suggested order will tend to reduce the number of forward references.)
 
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index bd109ef122..a443ff4ebf 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -1630,6 +1630,15 @@ a connect attempt.  This allows you to configure its options
 A bug that prevented the IO::Socket::protocol() accessor
 from ever returning the correct value has been corrected.
 
+IO::Socket::connect now uses non-blocking IO instead of alarm()
+to do connect timeouts.
+
+IO::Socket::accept now uses select() instead of alarm() for doing
+timeouts.
+
+IO::Socket::INET->new now sets $! correctly on failure. $@ is
+still set for backwards compatability.
+
 =item JPL
 
 Java Perl Lingo is now distributed with Perl.  See jpl/README
diff --git a/pod/perlpod.pod b/pod/perlpod.pod
index 0997c71738..49e0ffc767 100644
--- a/pod/perlpod.pod
+++ b/pod/perlpod.pod
@@ -289,9 +289,8 @@ B<pod2man> for details).  Thus, you shouldn't write things like C<the
 LE<lt>fooE<gt> manpage>, if you want the translated document to read
 sensibly.
 
-If you don need or want total control of the text used for a
-link in the output use the form LE<lt>show this text|fooE<gt>
-instead.
+If you need total control of the text used for a link in the output
+use the form LE<lt>show this text|fooE<gt> instead.
 
 =item *
 
diff --git a/pod/perlre.pod b/pod/perlre.pod
index 6dd98ae3bf..64f7f1cdcb 100644
--- a/pod/perlre.pod
+++ b/pod/perlre.pod
@@ -570,7 +570,7 @@ so you should only do so if you are also using taint checking.
 Better yet, use the carefully constrained evaluation within a Safe
 module.  See L<perlsec> for details about both these mechanisms.
 
-=item C<(?p{ code })>
+=item C<(??{ code })>
 
 B<WARNING>: This extended regular expression feature is considered
 highly experimental, and may be changed or deleted without notice.
@@ -592,7 +592,7 @@ The following pattern matches a parenthesized group:
 	     (?:
 		(?> [^()]+ )	# Non-parens without backtracking
 	      |
-		(?p{ $re })	# Group with matching parens
+		(??{ $re })	# Group with matching parens
 	     )*
 	     \)
 	  }x;
@@ -1175,7 +1175,7 @@ else in the whole regular expression.)
 For this grouping operator there is no need to describe the ordering, since
 only whether or not C<S> can match is important.
 
-=item C<(?p{ EXPR })>
+=item C<(??{ EXPR })>
 
 The ordering is the same as for the regular expression which is
 the result of EXPR.
diff --git a/pod/perltoc.pod b/pod/perltoc.pod
index 83d40d4241..0a67fdc232 100644
--- a/pod/perltoc.pod
+++ b/pod/perltoc.pod
@@ -1648,7 +1648,7 @@ cntrl, graph, print, punct, xdigit
 
 C<(?#text)>, C<(?imsx-imsx)>, C<(?:pattern)>, C<(?imsx-imsx:pattern)>,
 C<(?=pattern)>, C<(?!pattern)>, C<(?E<lt>=pattern)>, C<(?<!pattern)>, C<(?{
-code })>, C<(?p{ code })>, C<(?E<gt>pattern)>,
+code })>, C<(??{ code })>, C<(?E<gt>pattern)>,
 C<(?(condition)yes-pattern|no-pattern)>, C<(?(condition)yes-pattern)>
 
 =item Backtracking
@@ -1663,7 +1663,7 @@ C<(?(condition)yes-pattern|no-pattern)>, C<(?(condition)yes-pattern)>
 
 C<ST>, C<S|T>, C<S{REPEAT_COUNT}>, C<S{min,max}>, C<S{min,max}?>, C<S?>,
 C<S*>, C<S+>, C<S??>, C<S*?>, C<S+?>, C<(?E<gt>S)>, C<(?=S)>, C<(?<=S)>,
-C<(?!S)>, C<(?<!S)>, C<(?p{ EXPR })>,
+C<(?!S)>, C<(?<!S)>, C<(??{ EXPR })>,
 C<(?(condition)yes-pattern|no-pattern)>
 
 =item Creating custom RE engines
diff --git a/regcomp.c b/regcomp.c
index 7c6b761fd3..6d5a33b922 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -1734,7 +1734,7 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
 		nextchar();
 		*flagp = TRYAGAIN;
 		return NULL;
-	    case 'p':
+	    case '?':
 		logical = 1;
 		paren = *PL_regcomp_parse++;
 		/* FALL THROUGH */
diff --git a/t/op/misc.t b/t/op/misc.t
index b46c0ccb54..a595694e9b 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -482,7 +482,7 @@ new1new22DESTROY2new33DESTROY31DESTROY1
 ########
 re();
 sub re {
-    my $re = join '', eval 'qr/(?p{ $obj->method })/';
+    my $re = join '', eval 'qr/(??{ $obj->method })/';
     $re;
 }
 EXPECT
diff --git a/t/op/pat.t b/t/op/pat.t
index 142b82e2ad..103e6132b5 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -370,7 +370,7 @@ print "ok $test\n";
 $test++;
 
 my $matched;
-$matched = qr/\((?:(?>[^()]+)|(?p{$matched}))*\)/;
+$matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/;
 
 @ans = @ans1 = ();
 push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g;
@@ -866,7 +866,7 @@ print "ok $test\n";
 $test++;
 
 $brackets = qr{
-	         {  (?> [^{}]+ | (?p{ $brackets }) )* }
+	         {  (?> [^{}]+ | (??{ $brackets }) )* }
 	      }x;
 
 "{{}" =~ $brackets;
@@ -877,7 +877,7 @@ $test++;
 print "ok $test\n";		# Did we survive?
 $test++;
 
-"something { long { and } hairy" =~ m/((?p{ $brackets }))/;
+"something { long { and } hairy" =~ m/((??{ $brackets }))/;
 print "not " unless $1 eq "{ and }";
 print "ok $test\n";
 $test++;
diff --git a/toke.c b/toke.c
index e18a4c8df8..3af0896349 100644
--- a/toke.c
+++ b/toke.c
@@ -1270,7 +1270,7 @@ S_scan_const(pTHX_ char *start)
 		while (s < send && *s != ')')
 		    *d++ = *s++;
 	    } else if (s[2] == '{'
-		       || s[2] == 'p' && s[3] == '{') {	/* This should march regcomp.c */
+		       || s[2] == '?' && s[3] == '{') {	/* This should march regcomp.c */
 		I32 count = 1;
 		char *regparse = s + (s[2] == '{' ? 3 : 4);
 		char c;
diff --git a/utils/h2xs.PL b/utils/h2xs.PL
index c47418e824..333e891060 100644
--- a/utils/h2xs.PL
+++ b/utils/h2xs.PL
@@ -100,6 +100,14 @@ Omit the autogenerated stub POD section.
 Omit the XS portion.  Used to generate templates for a module which is not
 XS-based.  C<-c> and C<-f> are implicitly enabled.
 
+=item B<-a>
+
+Generate an accessor method for each element of structs and unions. The
+generated methods are named after the element name; will return the current
+value of the element if called without additional arguments; and will set
+the element to the supplied value (and return the old value) if called with
+an additional argument.
+
 =item B<-c>
 
 Omit C<constant()> from the .xs file and corresponding specialised
@@ -322,6 +330,7 @@ version: $H2XS_VERSION
     -O   Allow overwriting of a pre-existing extension directory.
     -P   Omit the stub POD section.
     -X   Omit the XS portion (implies both -c and -f).
+    -a   Generate get/set accessors for struct and union members (used with -x).
     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
     -d   Turn on debugging messages.
     -f   Force creation of the extension even if the C header does not exist.
@@ -339,8 +348,8 @@ extra_libraries
 }
 
 
-getopts("ACF:M:OPXcdfhn:o:p:s:v:x") || usage;
-use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_c
+getopts("ACF:M:OPXacdfhn:o:p:s:v:x") || usage;
+use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c
 	    $opt_d $opt_f $opt_h $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
 
 usage if $opt_h;
@@ -530,6 +539,7 @@ my $fdecls_parsed = [];
 my $typedef_rex;
 my %typedefs_pre;
 my %known_fnames;
+my %structs;
 
 my @fnames;
 my @fnames_no_prefix;
@@ -554,13 +564,17 @@ if( ! $opt_X ){  # use XS, unless it was disabled
       }
       warn "Scanning $filename for functions...\n";
       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
-	'add_cppflags' => $addflags;
+	'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
 
       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
       push(@$fdecls, @{$c->get('fdecls')});
 
       push @td, @{$c->get('typedefs_maybe')};
+      if ($opt_a) {
+	my $structs = $c->get('typedef_structs');
+	@structs{keys %$structs} = values %$structs;
+      }
 
       unless ($tmask_all) {
 	warn "Scanning $filename for typedefs...\n";
@@ -1148,6 +1162,47 @@ EOP
   }
 }
 
+sub print_accessors {
+  my($fh, $name, $struct) = @_;
+  return unless defined $struct && $name !~ /\s|_ANON/;
+  $name = normalize_type($name);
+  my $ptrname = normalize_type("$name *");
+  printf $fh <<"EOF";
+
+MODULE = $module		PACKAGE = ${name}Ptr		$prefix
+
+EOF
+  my @items = @$struct;
+  while (@items) {
+    my $item = shift @items;
+    if ($item->[0] =~ /_ANON/) {
+      if (defined $item->[1]) {
+	push @items, map [
+	  $_->[0], "$item->[1]_$_->[1]", "$item->[1].$_->[1]"
+	], @{ $structs{$item->[0]} };
+      } else {
+	push @items, @{ $structs{$item->[0]} };
+      }
+    } else {
+      my $type = normalize_type($item->[0]);
+      print $fh <<"EOF";
+$type
+$item->[1](THIS, __value = NO_INIT)
+	$ptrname THIS
+	$type __value
+    PROTOTYPE: \$;\$
+    CODE:
+	RETVAL = THIS->$item->[-1];
+	if (items > 1)
+	    THIS->$item->[-1] = __value;
+    OUTPUT:
+	RETVAL
+
+EOF
+    }
+  }
+}
+
 # Should be called before any actual call to normalize_type().
 sub get_typemap {
   # We do not want to read ./typemap by obvios reasons.
@@ -1240,6 +1295,11 @@ sub assign_typemap_entry {
 
 if ($opt_x) {
     for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+    if ($opt_a) {
+	while (my($name, $struct) = each %structs) {
+	    print_accessors(\*XS, $name, $struct);
+	}
+    }
 }
 
 close XS;
diff --git a/win32/Makefile b/win32/Makefile
index ddc7a9f856..3909230d4f 100644
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -1070,6 +1070,19 @@ test-notty : test-prep
 	$(PERLEXE) -I..\lib harness
 	cd ..\win32
 
+test-wide : test-prep
+	set HARNESS_PERL_SWITCHES=-C
+	cd ..\t
+	$(PERLEXE) -I..\lib harness
+	cd ..\win32
+
+test-wide-notty : test-prep
+	set PERL_SKIP_TTY_TEST=1
+	set HARNESS_PERL_SWITCHES=-C
+	cd ..\t
+	$(PERLEXE) -I..\lib harness
+	cd ..\win32
+
 clean : 
 	-@erase miniperlmain$(o)
 	-@erase $(MINIPERL)
diff --git a/win32/makefile.mk b/win32/makefile.mk
index fd34a06310..d727c9f13f 100644
--- a/win32/makefile.mk
+++ b/win32/makefile.mk
@@ -1284,7 +1284,16 @@ test : $(RIGHTMAKE) test-prep
 
 test-notty : test-prep
 	set PERL_SKIP_TTY_TEST=1 && \
-	cd ..\t && $(PERLEXE) -I.\lib harness
+	    cd ..\t && $(PERLEXE) -I.\lib harness
+
+test-wide : test-prep
+	set HARNESS_PERL_SWITCHES=-C && \
+	    cd ..\t && $(PERLEXE) -I..\lib harness
+
+test-wide-notty : test-prep
+	set PERL_SKIP_TTY_TEST=1 && \
+	    set HARNESS_PERL_SWITCHES=-C && \
+	    cd ..\t && $(PERLEXE) -I..\lib harness
 
 clean : 
 	-@erase miniperlmain$(o)