This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regexec.c: Remove redundant S_regcp_restore call
[perl5.git] / x2p / s2p.PL
index 70aa03d..8a5abae 100644 (file)
@@ -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
@@ -43,10 +64,12 @@ $Config{perlpath}
 
 print OUT <<'!NO!SUBS!';
 
-$0 =~ s/^.*?(\w+)$/$1/;
+$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;
@@ -68,14 +91,14 @@ psed - a stream editor
 A stream editor reads the input stream consisting of the specified files
 (or standard input, if none are given), processes is line by line by
 applying a script consisting of edit commands, and writes resulting lines
-to standard output. The filename `C<->' may be used to read standard input.
+to standard output. The filename 'C<->' may be used to read standard input.
 
 The edit script is composed from arguments of B<-e> options and
 script-files, in the given order. A single script argument may be specified
 as the first parameter.
 
 If this program is invoked with the name F<s2p>, it will act as a
-sed-to-Perl translator. See L<"sed Script Translation">.
+sed-to-Perl translator. See L<"SED SCRIPT TRANSLATION">.
 
 B<sed> returns an exit code of 0 on success or >0 if an error occurred.
 
@@ -132,7 +155,7 @@ pattern space for later use.
 A sed address is either a line number or a pattern, which may be combined
 arbitrarily to construct ranges. Lines are numbered across all input files.
 
-Any address may be followed by an exclamation mark (`C<!>'), selecting
+Any address may be followed by an exclamation mark ('C<!>'), selecting
 all lines not matching that address.
 
 =over 4
@@ -148,10 +171,10 @@ A dollar sign (C<$>) is the line number of the last line of the input stream.
 =item B</>I<regular expression>B</>
 
 A pattern address is a basic regular expression (see 
-L<"Basic Regular Expressions">), between the delimiting character C</>.
+L<"BASIC REGULAR EXPRESSIONS">), between the delimiting character C</>.
 Any other character except C<\> or newline may be used to delimit a
 pattern address when the initial delimiter is prefixed with a
-backslash (`C<\>').
+backslash ('C<\>').
 
 =back
 
@@ -186,6 +209,7 @@ literally.
 =cut
 
 my %ComTab;
+my %GenKey;
 #--------------------------------------------------------------------------
 $ComTab{'a'}=[ 1, 'txt', \&Emit,       '{ push( @Q, <<'."'TheEnd' ) }\n" ]; #ok
 
@@ -305,9 +329,9 @@ $ComTab{'l'}=[ 2, '',    \&Emit,       '{ _l() }'                        ]; #okU
 
 Print the contents of the pattern space: non-printable characters are
 shown in C-style escaped form; long lines are split and have a trailing
-`C<\>' at the point of the split; the true end of a line is marked with
-a `C<$>'. Escapes are: `\a', `\t', `\n', `\f', `\r', `\e' for
-BEL, HT, LF, FF, CR, ESC, respectively, and `\' followed by a three-digit
+^'C<\>' at the point of the split; the true end of a line is marked with
+a 'C<$>'. Escapes are: '\a', '\t', '\n', '\f', '\r', '\e' for
+BEL, HT, LF, FF, CR, ESC, respectively, and '\' followed by a three-digit
 octal number for all other non-printable characters.
 
 =cut
@@ -315,7 +339,7 @@ octal number for all other non-printable characters.
 #--------------------------------------------------------------------------
 $ComTab{'n'}=[ 2, '',    \&Emit,       <<'-X-'                           ]; #ok
 { print $_, "\n" if $doPrint;
-  printQ if @Q;
+  printQ() if @Q;
   $CondReg = 0;
   last CYCLE unless getsARGV();
   chomp();
@@ -332,7 +356,7 @@ there is no more input, processing is terminated.
 
 #--------------------------------------------------------------------------
 $ComTab{'N'}=[ 2, '',    \&Emit,       <<'-X-'                           ]; #ok
-{ printQ if @Q;
+{ printQ() if @Q;
   $CondReg = 0;
   last CYCLE unless getsARGV( $h );
   chomp( $h );
@@ -384,7 +408,6 @@ Branch to the end of the script and quit without starting a new cycle.
 
 #--------------------------------------------------------------------------
 $ComTab{'r'}=[ 1, 'str', \&Emit,       "{ _r( '-X-' ) }"                 ]; #ok
-### FIXME: lazy reading - big files???
 
 =item [1addr]B<r> I<file>
 
@@ -404,15 +427,15 @@ the pattern space that matches the I<regular expression>.
 Any character other than backslash or newline can be used instead of a 
 slash to delimit the regular expression and the replacement.
 To use the delimiter as a literal character within the regular expression
-and the replacement, precede the character by a backslash (`C<\>').
+and the replacement, precede the character by a backslash ('C<\>').
 
 Literal newlines may be embedded in the replacement string by
 preceding a newline with a backslash.
 
-Within the replacement, an ampersand (`C<&>') is replaced by the string
-matching the regular expression. The strings `C<\1>' through `C<\9>' are
-replaced by the corresponding subpattern (see L<"Basic Regular Expressions">).
-To get a literal `C<&>' or `C<\>' in the replacement text, precede it
+Within the replacement, an ampersand ('C<&>') is replaced by the string
+matching the regular expression. The strings 'C<\1>' through 'C<\9>' are
+replaced by the corresponding subpattern (see L<"BASIC REGULAR EXPRESSIONS">).
+To get a literal 'C<&>' or 'C<\>' in the replacement text, precede it
 by a backslash.
 
 The following I<flags> modify the behaviour of the B<s> command:
@@ -474,14 +497,15 @@ Swap the contents of the pattern space and the hold space.
 
 #--------------------------------------------------------------------------
 $ComTab{'y'}=[ 2, 'tra', \&Emit,       ''                                ]; #ok
+
 =item [2addr]B<y>B</>I<string1>B</>I<string2>B</>
 
-In the pattern space, replace all characters occuring in I<string1> by the
+In the pattern space, replace all characters occurring in I<string1> by the
 character at the corresponding position in I<string2>. It is possible
 to use any character (other than a backslash or newline) instead of a
 slash to delimit the strings.  Within I<string1> and I<string2>, a
 backslash followed by any character other than a newline is that literal
-character, and a backslash followed by an `n' is replaced by a newline
+character, and a backslash followed by an 'n' is replaced by a newline
 character.
 
 =cut
@@ -497,7 +521,7 @@ Prints the current line number on the standard output.
 
 #--------------------------------------------------------------------------
 $ComTab{':'}=[ 0, 'str', \&Label,      ''                                ]; #ok
+
 =item [0addr]B<:> [I<label>]
 
 The command specifies the position of the I<label>. It has no other effect.
@@ -526,7 +550,7 @@ $ComTab{'#'}=[ 0, 'str', \&Comment,    ''                                ]; #ok
 =item [0addr]B<#> [I<comment>]
 
 The entire line is ignored (treated as a comment). If, however, the first
-two characters in the script are `C<#n>', automatic printing of output is
+two characters in the script are 'C<#n>', automatic printing of output is
 suppressed, as if the B<-n> option were given on the command line.
 
 =back
@@ -542,11 +566,18 @@ $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
 #
-my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code );
+my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code, $Func );
+$Code = '';
 
 ##################
 #  Compile Time
@@ -659,7 +690,7 @@ sub EndBlock($$$$$$){
     if( defined( $jcom ) ){
        $rc = Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
     } else {
-       Warn( "unexpected `}'", $fl );
+       Warn( "unexpected '}'", $fl );
        $rc = 1;
     }
     $rc;
@@ -713,15 +744,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;
@@ -763,7 +800,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++;
        }
@@ -821,6 +858,7 @@ TheEnd
     if( defined( $path ) ){
         $wFiles{$path} = '';
        $code .= " _w( '$path' ) if \$s;\n";
+        $GenKey{'w'} = 1;
     }
     $code .= "}";
 }
@@ -887,15 +925,15 @@ as defined in ctype(3).
 If the first character after B<[> is B<^>, the sense of matching is
 inverted.
 
-To include a literal `C<^>', place it anywhere else but first. To
+To include a literal 'C<^>', place it anywhere else but first. To
 include a literal 'C<]>' place it first or immediately after an
-initial B<^>. To include a literal `C<->' make it the first (or
+initial B<^>. To include a literal 'C<->' make it the first (or
 second after B<^>) or last character, or the second endpoint of
 a range.
 
 The special bracket expression constructs C<[[:E<lt>:]]> and C<[[:E<gt>:]]> 
 match the null string at the beginning and end of a word respectively.
-(Note that neither is identical to Perl's `\b' atom.)
+(Note that neither is identical to Perl's '\b' atom.)
 
 =head2 Additional Atoms
 
@@ -950,7 +988,7 @@ sub bre2p($$$){
            ### backslash escapes
             my $nc = peek($pat,$ic);
             if( $nc eq '' ){
-                Warn( "`\\' cannot be last in pattern", $fl );
+                Warn( "'\\' cannot be last in pattern", $fl );
                 return undef();
             }
            $ic++;
@@ -970,7 +1008,7 @@ sub bre2p($$$){
                 $parlev--;
                $backref++;
                 if( $parlev < 0 ){
-                    Warn( "unmatched `\\)'", $fl );
+                    Warn( "unmatched '\\)'", $fl );
                     return undef();
                 }
                 $res .= ')';
@@ -978,7 +1016,7 @@ sub bre2p($$$){
             } elsif( $nc eq '{' ){ ## repetition factor \{<i>[,[<j>]]\}
                 my $endpos = index( $pat, '\\}', $ic );
                 if( $endpos < 0 ){
-                    Warn( "unmatched `\\{'", $fl );
+                    Warn( "unmatched '\\{'", $fl );
                     return undef();
                 }
                 my $rep = substr( $pat, $ic+1, $endpos-($ic+1) );
@@ -992,7 +1030,7 @@ sub bre2p($$$){
                     my $max = $3;
                     if( length( $max ) ){
                         if( $max < $min ){
-                            Warn( "maximum less than minimum in `\\{$rep\\}'",
+                            Warn( "maximum less than minimum in '\\{$rep\\}'",
                                  $fl );
                             return undef();
                         }
@@ -1010,7 +1048,7 @@ sub bre2p($$$){
                        $res .= "{$min$com$max}";
                    }
                 } else {
-                    Warn( "invalid repeat clause `\\{$rep\\}'", $fl );
+                    Warn( "invalid repeat clause '\\{$rep\\}'", $fl );
                     return undef();
                 }
 
@@ -1040,7 +1078,7 @@ sub bre2p($$$){
                ## \<closing bracketing-delimiter> - keep '\'
                $res .= "\\$nc";
 
-            } else { ## \ <char> => <char> ("as if `\' were not present")
+            } else { ## \ <char> => <char> ("as if '\' were not present")
                 $res .= $nc;
             }
 
@@ -1068,7 +1106,7 @@ sub bre2p($$$){
            }
            # check that [ is not trailing
            if( $ic >= length( $pat ) - 1 ){
-               Warn( "unmatched `['", $fl );
+               Warn( "unmatched '['", $fl );
                return undef();
            }
            # look for [:...:] and x-y
@@ -1076,7 +1114,7 @@ sub bre2p($$$){
            if( $rstr =~ /^((?:\[:\(\w+|[><]\):\]|[^]-](?:-[^]])?)*)/ ){
                my $cnt = $1;
                $ic += length( $cnt );
-               $cnt =~ s/([\\\$])/\\$1/g; # `\', `$' are magic in Perl []
+               $cnt =~ s/([\\\$])/\\$1/g; # '\', '$' are magic in Perl []
                # try some simplifications
                my $red = $cnt;
                if( $red =~ s/0-9// ){
@@ -1093,7 +1131,7 @@ sub bre2p($$$){
 
            }
 
-           ## may have a trailing `-' before `]'
+           ## may have a trailing '-' before ']'
            if( $ic < length($pat) - 1 &&
                 substr( $pat, $ic+1 ) =~ /^(-?])/ ){
                $ic += length( $1 );
@@ -1102,7 +1140,7 @@ sub bre2p($$$){
                $add =~ s/^\[(\^?)(\\[dw])]$/ $1 eq '^' ? uc($2) : $2 /e;
                $res .= $add;
            } else {
-               Warn( "unmatched `['", $fl );
+               Warn( "unmatched '['", $fl );
                return undef();
            }
 
@@ -1127,7 +1165,7 @@ sub bre2p($$$){
     }
 
     if( $parlev ){
-       Warn( "unmatched `\\('", $fl );
+       Warn( "unmatched '\\('", $fl );
        return undef();
     }
 
@@ -1155,7 +1193,7 @@ sub sub2p($$$){
            ### backslash escapes
             my $nc = peek($subst,$ic);
             if( $nc eq '' ){
-                Warn( "`\\' cannot be last in substitution", $fl );
+                Warn( "'\\' cannot be last in substitution", $fl );
                 return undef();
             }
            $ic++;
@@ -1245,13 +1283,13 @@ sub Parse(){
                    next;
                }
             } else {
-               Warn( "invalid address after `,'", $fl );
+               Warn( "invalid address after ','", $fl );
                $error++;
                next;
             }
         }
 
-        # address modifier `!'
+        # address modifier '!'
         #
         $negated = $cmd =~ s/^!\s*//;
        if( defined( $addr1 ) ){
@@ -1270,13 +1308,14 @@ sub Parse(){
        #
         if( $cmd !~ s/^([:#={}abcdDgGhHilnNpPqrstwxy])\s*// ){
            my $h = substr( $cmd, 0, 1 );
-           Warn( "unknown command `$h'", $fl );
+           Warn( "unknown command '$h'", $fl );
            $error++;
            next;
        }
         my $key = $1;
 
        my $tabref = $ComTab{$key};
+       $GenKey{$key} = 1;
        if( $naddr > $tabref->[0] ){
            Warn( "excess address(es)", $fl );
            $error++;
@@ -1316,13 +1355,13 @@ sub Parse(){
        } elsif( $tabref->[1] eq 'sub' ){
            # s///
            if( ! length( $cmd ) ){
-               Warn( "`s' command requires argument", $fl );
+               Warn( "'s' command requires argument", $fl );
                $error++;
                next;
            }
            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++;
@@ -1360,7 +1399,7 @@ sub Parse(){
                $write = $1 if $cmd =~ s/w\s*(.*)$//;
                ### $nmatch =~ s/^(\d)\1*$/$1/; ### may be dangerous?
                if( $global && length( $nmatch ) || length( $nmatch ) > 1 ){
-                   Warn( "conflicting flags `$global$nmatch'", $fl );
+                   Warn( "conflicting flags '$global$nmatch'", $fl );
                    $error++;
                    next;
                }
@@ -1392,30 +1431,30 @@ sub Parse(){
                 $Code .= "# $Commands[$icom]\n" if $doGenerate;
            }
            if( ! length( $cmd ) ){
-               Warn( "`y' command requires argument", $fl );
+               Warn( "'y' command requires argument", $fl );
                $error++;
                next;
            }
            my $d = substr( $cmd, 0, 1 ); $cmd = substr( $cmd, 1 );
            if( $d eq '\\' ){
-               Warn( "`\\' not valid as delimiter in `y' command", $fl );
+               Warn( "'\\' not valid as delimiter in 'y' command", $fl );
                $error++;
                next;
            }
            my $fr = stripTrans( $d, \$cmd );
            if( ! defined( $fr ) || ! length( $cmd ) ){
-               Warn( "malformed `y' command argument", $fl );
+               Warn( "malformed 'y' command argument", $fl );
                $error++;
                next;
            }
            my $to = stripTrans( $d, \$cmd );
            if( ! defined( $to ) ){
-               Warn( "malformed `y' command argument", $fl );
+               Warn( "malformed 'y' command argument", $fl );
                $error++;
                next;
            }
            if( length($fr) != length($to) ){
-               Warn( "string lengths in `y' command differ", $fl );
+               Warn( "string lengths in 'y' command differ", $fl );
                $error++;
                next;
            }
@@ -1448,14 +1487,14 @@ sub Parse(){
 
     while( @BlockStack ){
        my $bl = pop( @BlockStack );
-       Warn( "start of unterminated `{'", $bl );
+       Warn( "start of unterminated '{'", $bl );
         $error++;
     }
 
     for my $lab ( keys( %Label ) ){
        if( ! exists( $Label{$lab}{defined} ) ){
            for my $used ( @{$Label{$lab}{used}} ){
-               Warn( "undefined label `$lab'", $used );
+               Warn( "undefined label '$lab'", $used );
                $error++;
            }
        }
@@ -1532,7 +1571,7 @@ while( @ARGV && $ARGV[0] =~ /^-(.)(.*)$/ ){
     } elsif( $opt eq 'a' ){
        $doOpenWrite = 0;
     } else {
-        Warn( "illegal option `$opt'" );
+        Warn( "illegal option '$opt'" );
         usage();
         exit( 1 );
     }
@@ -1557,8 +1596,10 @@ print STDERR "Files: @ARGV\n" if $useDEBUG;
 
 # generate leading code
 #
-    $Code = <<'[TheEnd]';
+$Func = <<'[TheEnd]';
 
+# openARGV: open 1st input file
+#
 sub openARGV(){
     unshift( @ARGV, '-' ) unless @ARGV;
     my $file = shift( @ARGV );
@@ -1567,6 +1608,8 @@ sub openARGV(){
     $isEOF = 0;
 }
 
+# getsARGV: Read another input line into argument (default: $_).
+#           Move on to next input file, and reset EOF flag $isEOF.
 sub getsARGV(;\$){
     my $argref = @_ ? shift() : \$_; 
     while( $isEOF || ! defined( $$argref = <ARG> ) ){
@@ -1580,10 +1623,14 @@ sub getsARGV(;\$){
     1;
 }
 
+# eofARGV: end-of-file test
+#
 sub eofARGV(){
     return @ARGV == 0 && ( $isEOF = eof( ARG ) );
 }
 
+# makeHandle: Generates another file handle for some file (given by its path)
+#             to be written due to a w command or an s command's w flag.
 sub makeHandle($){
     my( $path ) = @_;
     my $handle;
@@ -1600,66 +1647,18 @@ sub makeHandle($){
     return $handle;
 }
 
-sub _r($){
-    my $path = shift();
-    push( @Q, \$path );
-}
-
-sub _l(){        
-    my $h = $_;
-    my $mcpl = 70;
-    $h =~ s/\\/\\\\/g;
-    if( $h =~ /[^[:print:]]/ ){
-       $h =~ s/\a/\\a/g;
-       $h =~ s/\f/\\f/g;
-       $h =~ s/\n/\\n/g;
-       $h =~ s/\t/\\t/g;
-       $h =~ s/\r/\\r/g;
-       $h =~ s/\e/\\e/g;
-        $h =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge;
-    }
-    while( length( $h ) > $mcpl ){
-       my $l = substr( $h, 0, $mcpl-1 );
-       $h = substr( $h, $mcpl );
-       # remove incomplete \-escape from end of line
-       if( $l =~ s/(?<!\\)(\\[0-7]{0,2})$// ){
-           $h = $1 . $h;
-       }
-       print $l, "\\\n";
-    }
-    print "$h\$\n";
-}
-
-sub _w($){
-    my $path   = shift();
-    my $handle = $wFiles{$path};
-    if( ! $doOpenWrite &&
-       ! defined( fileno( $handle ) ) ){
-       open( $handle, ">$path" )
-       || die( "$0: $path: cannot open ($!)\n" );
-    }
-    print $handle $_, "\n";
-}
-
-# condition register test/reset
-#
-sub _t(){
-    my $res = $CondReg;
-    $CondReg = 0;
-    $res;
-}
-
-# printQ
-#
+# printQ: Print queued output which is either a string or a reference
+#         to a pathname.
 sub printQ(){
     for my $q ( @Q ){
        if( ref( $q ) ){
+            # flush open w files so that reading this file gets it all
            if( exists( $wFiles{$$q} ) && $wFiles{$$q} ne '' ){
                open( $wFiles{$$q}, ">>$$q" );
            }
+            # copy file to stdout: slow, but safe
            if( open( RF, "<$$q" ) ){
-               my $line;
-               while( defined( $line = <RF> ) ){
+               while( defined( my $line = <RF> ) ){
                    print $line;
                }
                close( RF );
@@ -1671,6 +1670,18 @@ sub printQ(){
     undef( @Q );
 }
 
+[TheEnd]
+
+# generate the sed loop
+#
+$Code .= <<'[TheEnd]';
+sub openARGV();
+sub getsARGV(;\$);
+sub eofARGV();
+sub printQ();
+
+# Run: the sed loop reading input and applying the script
+#
 sub Run(){
     my( $h, $icnt, $s, $n );
     # hack (not unbreakable :-/) to avoid // matching an empty string
@@ -1710,16 +1721,102 @@ EOS:    if( $doPrint ){
 }
 [TheEnd]
 
+
+# append optional functions, prepend prototypes
+#
+my $Proto = "# prototypes\n";
+if( $GenKey{'l'} ){
+    $Proto .= "sub _l();\n";
+    $Func .= <<'[TheEnd]';
+# _l: l command processing
+#
+sub _l(){        
+    my $h = $_;
+    my $mcpl = 70;
+    # transform non printing chars into escape notation
+    $h =~ s/\\/\\\\/g;
+    if( $h =~ /[^[:print:]]/ ){
+       $h =~ s/\a/\\a/g;
+       $h =~ s/\f/\\f/g;
+       $h =~ s/\n/\\n/g;
+       $h =~ s/\t/\\t/g;
+       $h =~ s/\r/\\r/g;
+       $h =~ s/\e/\\e/g;
+        $h =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge;
+    }
+    # split into lines of length $mcpl
+    while( length( $h ) > $mcpl ){
+       my $l = substr( $h, 0, $mcpl-1 );
+       $h = substr( $h, $mcpl );
+       # remove incomplete \-escape from end of line
+       if( $l =~ s/(?<!\\)(\\[0-7]{0,2})$// ){
+           $h = $1 . $h;
+       }
+       print $l, "\\\n";
+    }
+    print "$h\$\n";
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'r'} ){
+    $Proto .= "sub _r(\$);\n";
+    $Func .= <<'[TheEnd]';
+# _r: r command processing: Save a reference to the pathname.
+#
+sub _r($){
+    my $path = shift();
+    push( @Q, \$path );
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'t'} ){
+    $Proto .= "sub _t();\n";
+    $Func .= <<'[TheEnd]';
+# _t: t command - condition register test/reset
+#
+sub _t(){
+    my $res = $CondReg;
+    $CondReg = 0;
+    $res;
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'w'} ){
+    $Proto .= "sub _w(\$);\n";
+    $Func .= <<'[TheEnd]';
+# _w: w command and s command's w flag - write to file 
+#
+sub _w($){
+    my $path   = shift();
+    my $handle = $wFiles{$path};
+    if( ! $doOpenWrite && ! defined( fileno( $handle ) ) ){
+       open( $handle, ">$path" )
+       || die( "$0: $path: cannot open ($!)\n" );
+    }
+    print $handle $_, "\n";
+}
+
+[TheEnd]
+}
+
+$Code = $Proto . $Code;
+
 # magic "#n" - same as -n option
 #
 $doAutoPrint = 0 if substr( $Commands[0], 0, 2 ) eq '#n';
 
 # eval code - check for errors
 #
-print "Code:\n$Code" if $useDEBUG;
-eval $Code;
+print "Code:\n$Code$Func" if $useDEBUG;
+eval $Code . $Func;
 if( $@ ){
-    print "Code:\n$Code";
+    print "Code:\n$Code$Func";
     die( "$0: internal error - generated incorrect Perl code: $@\n" );
 }
 
@@ -1728,12 +1825,12 @@ if( $doGenerate ){
     # write full Perl program
     #
  
-    # bang line, declarations
+    # bang line, declarations, prototypes
     print <<TheEnd;
 #!$perlpath -w
 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
   if 0;
-\$0 =~ s/^.*?(\\w+)\$/\$1/;
+\$0 =~ s/^.*?(\\w+)\[\\.\\w+\]*\$/\$1/;
 
 use strict;
 use Symbol;
@@ -1754,17 +1851,17 @@ TheEnd
    }
 
    print $Code;
-   print "&Run()\n";
+   print "Run();\n";
+   print $Func;
    exit( 0 );
 
 } else {
 
     # execute: make handles (and optionally open) all w files; run!
-
     for my $p ( keys( %wFiles ) ){
         exit( 1 ) unless makeHandle( $p );
     }
-    &Run();
+    Run();
 }
 
 
@@ -1777,27 +1874,27 @@ 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.
 
-=item `[' cannot be last in pattern
+=item '[' cannot be last in pattern
 
-A `[' in a BRE indicates the beginning of a I<bracket expression>.
+A '[' in a BRE indicates the beginning of a I<bracket expression>.
 
-=item `\' cannot be last in pattern
+=item '\' cannot be last in pattern
 
-A `\' in a BRE is used to make the subsequent character literal.
+A '\' in a BRE is used to make the subsequent character literal.
 
-=item `\' cannot be last in substitution
+=item '\' cannot be last in substitution
 
-A `\' in a subsitution string is used to make the subsequent character literal.
+A '\' in a substitution string is used to make the subsequent character literal.
 
-=item conflicting flags `%s'
+=item conflicting flags '%s'
 
-In an B<s> command, either the `g' flag and an n-th occurrence flag, or
+In an B<s> command, either the 'g' flag and an n-th occurrence flag, or
 multiple n-th occurrence flags are specified. Note that only the digits
-`1' through `9' are permitted.
+^'1' through '9' are permitted.
 
 =item duplicate label %s (first defined at %s)
 
@@ -1807,20 +1904,20 @@ The command has more than the permitted number of addresses.
 
 =item extra characters after command (%s)
 
-=item illegal option `%s'
+=item illegal option '%s'
 
 =item improper delimiter in s command
 
-The BRE and substitution may not be delimited with `\' or newline.
+The BRE and substitution may not be delimited with '\' or newline.
 
-=item invalid address after `,'
+=item invalid address after ','
 
 =item invalid backreference (%s)
 
 The specified backreference number exceeds the number of backreferences
 in the BRE.
 
-=item invalid repeat clause `\{%s\}'
+=item invalid repeat clause '\{%s\}'
 
 The repeat clause does not contain a valid integer value, or pair of
 values.
@@ -1833,34 +1930,34 @@ values.
 
 =item malformed substitution expression
 
-=item malformed `y' command argument
+=item malformed 'y' command argument
 
 The first or second string of a B<y> command  is syntactically incorrect.
 
-=item maximum less than minimum in `\{%s\}'
+=item maximum less than minimum in '\{%s\}'
 
 =item no script command given
 
 There must be at least one B<-e> or one B<-f> option specifying a
 script or script file.
 
-=item `\' not valid as delimiter in `y' command
+=item '\' not valid as delimiter in 'y' command
 
 =item option -e requires an argument
 
 =item option -f requires an argument
 
-=item `s' command requires argument
+=item 's' command requires argument
 
-=item start of unterminated `{'
+=item start of unterminated '{'
 
-=item string lengths in `y' command differ
+=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'
+=item undefined label '%s'
 
-=item unexpected `}'
+=item unexpected '}'
 
 A B<}> command without a preceding B<{> command was encountered.
 
@@ -1869,23 +1966,23 @@ A B<}> command without a preceding B<{> command was encountered.
 The end of the script was reached although a text line after a
 B<a>, B<c> or B<i> command indicated another line.
 
-=item unknown command `%s'
+=item unknown command '%s'
 
-=item unterminated `['
+=item unterminated '['
 
 A BRE contains an unterminated bracket expression.
 
-=item unterminated `\('
+=item unterminated '\('
 
 A BRE contains an unterminated backreference.
 
-=item `\{' without closing `\}'
+=item '\{' without closing '\}'
 
 A BRE contains an unterminated bounds specification.
 
-=item `\)' without preceding `\('
+=item '\)' without preceding '\('
 
-=item `y' command requires argument
+=item 'y' command requires argument
 
 =back
 
@@ -1923,12 +2020,12 @@ perl(1), re_format(7)
 
 =head1 BUGS
 
-The B<l> command will show escape characters (ESC) as `C<\e>', but
+The B<l> command will show escape characters (ESC) as 'C<\e>', but
 a vertical tab (VT) in octal.
 
 Trailing spaces are truncated from labels in B<:>, B<t> and B<b> commands.
 
-The meaning of an empty regular expression (`C<//>'), as defined by B<sed>,
+The meaning of an empty regular expression ('C<//>'), as defined by B<sed>,
 is "the last pattern used, at run time". This deviates from the Perl
 interpretation, which will re-use the "last last successfully executed
 regular expression". Since keeping track of pattern usage would create
@@ -1963,9 +2060,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;