X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=x2p%2Fs2p.PL;h=d1ce6ea45ed1ad299a56e8157a3f6098ef6f8568;hb=585901d452c159529f56fbe107b0f67b21ec5bbc;hp=9b62caac9c8be490472abc5e7c4da2ed18855414;hpb=9ae2b9a01756a2a2ea4071ab263cdb052d634e1a;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/x2p/s2p.PL b/x2p/s2p.PL
index 9b62caa..d1ce6ea 100644
--- a/x2p/s2p.PL
+++ b/x2p/s2p.PL
@@ -3,6 +3,27 @@
 use Config;
 use File::Basename qw(&basename &dirname);
 use Cwd;
+use subs qw(link);
+
+sub link { # This is a cut-down version of installperl:link().
+    my($from,$to) = @_;
+    my($success) = 0;
+
+    eval {
+	CORE::link($from, $to)
+	    ? $success++
+	    : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
+	      ? die "AFS"  # okay inside eval {}
+	      : die "Couldn't link $from to $to: $!\n";
+    };
+    if ($@) {
+	require File::Copy;
+	File::Copy::copy($from, $to)
+	    ? $success++
+	    : warn "Couldn't copy $from to $to: $!\n";
+    }
+    $success;
+}
 
 # List explicitly here the variables you want Configure to
 # generate.  Metaconfig only looks for shell variables, so you
@@ -48,6 +69,7 @@ $0 =~ s/^.*?(\w+)[\.\w]*$/$1/;
 # (p)sed - a stream editor
 # History:  Aug 12 2000: Original version.
 #           Mar 25 2002: Rearrange generated Perl program.
+#           Jul 23 2007: Fix bug in regex stripping (M.Thorland)
 
 use strict;
 use integer;
@@ -543,7 +565,13 @@ $useEXTBRE =~ s/[^<>wWyB]//g; # gawk RE's handle these
 my $doAutoPrint = 1;          # automatic printing of pattern space (-n => 0)
 my $doOpenWrite = 1;          # open w command output files at start (-a => 0)
 my $svOpenWrite = 0;          # save $doOpenWrite
-my $doGenerate  = $0 eq 's2p';
+
+# lower case $0 below as a VMSism.  The VMS build procedure creates the
+# s2p file traditionally in upper case on the disk.  When VMS is in a
+# case preserved or case sensitive mode, $0 will be returned in the exact
+# case which will be on the disk, and that is not predictable at this time.
+
+my $doGenerate  = lc($0) eq 's2p';
 
 # Collected and compiled script
 #
@@ -715,15 +743,21 @@ sub Comment($$$$$$){
     0;
 }
 
-
-sub stripRegex($$){
-    my( $del, $sref ) = @_;
+# stripRegex from the current command. If we're in the first
+# part of s///, trailing spaces have to be kept as the initial
+# part of the replacement string.
+#
+sub stripRegex($$;$){
+    my( $del, $sref, $sub ) = @_;
     my $regex = $del;
     print "stripRegex:$del:$$sref:\n" if $useDEBUG;
     while( $$sref =~ s{^(.*?)(\\*)\Q$del\E(\s*)}{}s ){
         my $sl = $2;
 	$regex .= $1.$sl.$del;
 	if( length( $sl ) % 2 == 0 ){
+            if( $sub && (length( $3 ) > 0) ){
+                $$sref = $3 . $$sref;
+	    }
 	    return $regex;
 	}
 	$regex .= $3;
@@ -765,7 +799,7 @@ sub makey($$$){
 	my $fc = substr($fr,$i,1);
 	my $tc = substr($to,$i,1);
 	if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){
-	    Warn( "ambiguos translation for character `$fc' in `y' command",
+	    Warn( "ambiguous translation for character `$fc' in `y' command",
 		  $fl );
 	    $error++;
 	}
@@ -1326,7 +1360,7 @@ sub Parse(){
 	    }
 	    if( $cmd =~ s{^([^\\\n])}{} ){
 		my $del = $1;
-		my $regex = stripRegex( $del, \$cmd );
+		my $regex = stripRegex( $del, \$cmd, "s" );
 		if( ! defined( $regex ) ){
 		    Warn( "malformed regular expression", $fl );
 		    $error++;
@@ -1839,7 +1873,7 @@ See L<"Additional Atoms">.
 
 =over 4
 
-=item ambiguos translation for character `%s' in `y' command
+=item ambiguous translation for character `%s' in `y' command
 
 The indicated character appears twice, with different translations.
 
@@ -1918,7 +1952,7 @@ script or script file.
 
 =item string lengths in `y' command differ
 
-The translation table strings in a B<y> commanf must have equal lengths.
+The translation table strings in a B<y> command must have equal lengths.
 
 =item undefined label `%s'
 
@@ -2025,9 +2059,9 @@ way you wish, provided you do not restrict others from doing the same.
 close OUT or die "Can't close $file: $!";
 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 unlink 'psed';
-print "Linking s2p to psed.\n";
+print "Linking $file to psed.\n";
 if (defined $Config{d_link}) {
-  link 's2p', 'psed';
+  link $file, 'psed';
 } else {
   unshift @INC, '../lib';
   require File::Copy;