[p5sagit/p5-mst-13.2.git] / x2p / s2p.PL

#!/usr/local/bin/perl

use Config;
use File::Basename qw(&basename &dirname);

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
chdir(dirname($0));
($file = basename($0)) =~ s/\.PL$//;
$file =~ s/\.pl$//
	if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"

open OUT,">$file" or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

print OUT <<"!GROK!THIS!";
$Config{'startperl'}
    eval 'exec perl -S \$0 "\$@"'
	if 0;
\$startperl = "$Config{startperl}";
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

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

# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
#
# $Log:	s2p.SH,v $

=head1 NAME

s2p - Sed to Perl translator

=head1 SYNOPSIS

B<s2p [options] filename>

=head1 DESCRIPTION

I<S2p> takes a sed script specified on the command line (or from
standard input) and produces a comparable I<perl> script on the
standard output.

=head2 Options

Options include:

=over 5

=item B<-DE<lt>numberE<gt>>

sets debugging flags.

=item B<-n>

specifies that this sed script was always invoked with a B<sed -n>.
Otherwise a switch parser is prepended to the front of the script.

=item B<-p>

specifies that this sed script was never invoked with a B<sed -n>.
Otherwise a switch parser is prepended to the front of the script.

=back

=head2 Considerations

The perl script produced looks very sed-ish, and there may very well
be better ways to express what you want to do in perl.  For instance,
s2p does not make any use of the split operator, but you might want
to.

The perl script you end up with may be either faster or slower than
the original sed script.  If you're only interested in speed you'll
just have to try it both ways.  Of course, if you want to do something
sed doesn't do, you have no choice.  It's often possible to speed up
the perl script by various methods, such as deleting all references to
$\ and chop.

=head1 ENVIRONMENT

S2p uses no environment variables.

=head1 AUTHOR

Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt>

=head1 FILES

=head1 SEE ALSO

 perl	The perl compiler/interpreter
 
 a2p	awk to perl translator

=head1 DIAGNOSTICS

=head1 BUGS

=cut

$indent = 4;
$shiftwidth = 4;
$l = '{'; $r = '}';

while ($ARGV[0] =~ /^-/) {
    $_ = shift;
  last if /^--/;
    if (/^-D/) {
	$debug++;
	open(BODY,'>-');
	next;
    }
    if (/^-n/) {
	$assumen++;
	next;
    }
    if (/^-p/) {
	$assumep++;
	next;
    }
    die "I don't recognize this switch: $_\n";
}

unless ($debug) {
    open(BODY,">/tmp/sperl$$") ||
      &Die("Can't open temp file: $!\n");
}

if (!$assumen && !$assumep) {
    print BODY &q(<<'EOT');
:	while ($ARGV[0] =~ /^-/) {
:	    $_ = shift;
:	  last if /^--/;
:	    if (/^-n/) {
:		$nflag++;
:		next;
:	    }
:	    die "I don't recognize this switch: $_\\n";
:	}
:	
EOT
}

print BODY &q(<<'EOT');
:	#ifdef PRINTIT
:	#ifdef ASSUMEP
:	$printit++;
:	#else
:	$printit++ unless $nflag;
:	#endif
:	#endif
:	<><>
:	$\ = "\n";		# automatically add newline on print
:	<><>
:	#ifdef TOPLABEL
:	LINE:
:	while (chop($_ = <>)) {
:	#else
:	LINE:
:	while (<>) {
:	    chop;
:	#endif
EOT

LINE:
while (<>) {

    # Wipe out surrounding whitespace.

    s/[ \t]*(.*)\n$/$1/;

    # Perhaps it's a label/comment.

    if (/^:/) {
	s/^:[ \t]*//;
	$label = &make_label($_);
	if ($. == 1) {
	    $toplabel = $label;
	    if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
		$_ = <>;
		redo LINE; # Never referenced, so delete it if not a comment.
	    }
	}
	$_ = "$label:";
	if ($lastlinewaslabel++) {
	    $indent += 4;
	    print BODY &tab, ";\n";
	    $indent -= 4;
	}
	if ($indent >= 2) {
	    $indent -= 2;
	    $indmod = 2;
	}
	next;
    } else {
	$lastlinewaslabel = '';
    }

    # Look for one or two address clauses

    $addr1 = '';
    $addr2 = '';
    if (s/^([0-9]+)//) {
	$addr1 = "$1";
	$addr1 = "\$. == $addr1" unless /^,/;
    }
    elsif (s/^\$//) {
	$addr1 = 'eof()';
    }
    elsif (s|^/||) {
	$addr1 = &fetchpat('/');
    }
    if (s/^,//) {
	if (s/^([0-9]+)//) {
	    $addr2 = "$1";
	} elsif (s/^\$//) {
	    $addr2 = "eof()";
	} elsif (s|^/||) {
	    $addr2 = &fetchpat('/');
	} else {
	    &Die("Invalid second address at line $.\n");
	}
	if ($addr2 =~ /^\d+$/) {
	    $addr1 .= "..$addr2";
	}
	else {
	    $addr1 .= "...$addr2";
	}
    }

    # Now we check for metacommands {, }, and ! and worry
    # about indentation.

    s/^[ \t]+//;
    # a { to keep vi happy
    if ($_ eq '}') {
	$indent -= 4;
	next;
    }
    if (s/^!//) {
	$if = 'unless';
	$else = "$r else $l\n";
    } else {
	$if = 'if';
	$else = '';
    }
    if (s/^{//) {	# a } to keep vi happy
	$indmod = 4;
	$redo = $_;
	$_ = '';
	$rmaybe = '';
    } else {
	$rmaybe = "\n$r";
	if ($addr2 || $addr1) {
	    $space = ' ' x $shiftwidth;
	} else {
	    $space = '';
	}
	$_ = &transmogrify();
    }

    # See if we can optimize to modifier form.

    if ($addr1) {
	if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
	  $_ !~ / if / && $_ !~ / unless /) {
	    s/;$/ $if $addr1;/;
	    $_ = substr($_,$shiftwidth,1000);
	} else {
	    $_ = "$if ($addr1) $l\n$change$_$rmaybe";
	}
	$change = '';
	next LINE;
    }
} continue {
    @lines = split(/\n/,$_);
    for (@lines) {
	unless (s/^ *<<--//) {
	    print BODY &tab;
	}
	print BODY $_, "\n";
    }
    $indent += $indmod;
    $indmod = 0;
    if ($redo) {
	$_ = $redo;
	$redo = '';
	redo LINE;
    }
}
if ($lastlinewaslabel++) {
    $indent += 4;
    print BODY &tab, ";\n";
    $indent -= 4;
}

if ($appendseen || $tseen || !$assumen) {
    $printit++ if $dseen || (!$assumen && !$assumep);
    print BODY &q(<<'EOT');
:	#ifdef SAWNEXT
:	}
:	continue {
:	#endif
:	#ifdef PRINTIT
:	#ifdef DSEEN
:	#ifdef ASSUMEP
:	    print if $printit++;
:	#else
:	    if ($printit)
:		{ print; }
:	    else
:		{ $printit++ unless $nflag; }
:	#endif
:	#else
:	    print if $printit;
:	#endif
:	#else
:	    print;
:	#endif
:	#ifdef TSEEN
:	    $tflag = 0;
:	#endif
:	#ifdef APPENDSEEN
:	    if ($atext) { chop $atext; print $atext; $atext = ''; }
:	#endif
EOT

print BODY &q(<<'EOT');
:	}
EOT
}

close BODY;

unless ($debug) {
    open(HEAD,">/tmp/sperl2$$.c")
      || &Die("Can't open temp file 2: $!\n");
    print HEAD "#define PRINTIT\n"	if $printit;
    print HEAD "#define APPENDSEEN\n"	if $appendseen;
    print HEAD "#define TSEEN\n"	if $tseen;
    print HEAD "#define DSEEN\n"	if $dseen;
    print HEAD "#define ASSUMEN\n"	if $assumen;
    print HEAD "#define ASSUMEP\n"	if $assumep;
    print HEAD "#define TOPLABEL\n"	if $toplabel;
    print HEAD "#define SAWNEXT\n"	if $sawnext;
    if ($opens) {print HEAD "$opens\n";}
    open(BODY,"/tmp/sperl$$")
      || &Die("Can't reopen temp file: $!\n");
    while (<BODY>) {
	print HEAD $_;
    }
    close HEAD;

    print &q(<<"EOT");
:	$startperl
:	eval 'exec perl -S \$0 \${1+"\$@"}'
:		if \$running_under_some_shell;
:	
EOT
    open(BODY,"cc -E /tmp/sperl2$$.c |") ||
	&Die("Can't reopen temp file: $!\n");
    while (<BODY>) {
	/^# [0-9]/ && next;
	/^[ \t]*$/ && next;
	s/^<><>//;
	print;
    }
}

&Cleanup;
exit;

sub Cleanup {
    chdir "/tmp";
    unlink "sperl$$", "sperl2$$", "sperl2$$.c";
}
sub Die {
    &Cleanup;
    die $_[0];
}
sub tab {
    "\t" x ($indent / 8) . ' ' x ($indent % 8);
}
sub make_filehandle {
    local($_) = $_[0];
    local($fname) = $_;
    if (!$seen{$fname}) {
	$_ = "FH_" . $_ if /^\d/;
	s/[^a-zA-Z0-9]/_/g;
	s/^_*//;
	$_ = "\U$_";
	if ($fhseen{$_}) {
	    for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
	    $_ .= $tmp;
	}
	$fhseen{$_} = 1;
	$opens .= &q(<<"EOT");
:	open($_, '>$fname') || die "Can't create $fname: \$!";
EOT
	$seen{$fname} = $_;
    }
    $seen{$fname};
}

sub make_label {
    local($label) = @_;
    $label =~ s/[^a-zA-Z0-9]/_/g;
    if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
    $label = substr($label,0,8);

    # Could be a reserved word, so capitalize it.
    substr($label,0,1) =~ y/a-z/A-Z/
      if $label =~ /^[a-z]/;

    $label;
}

sub transmogrify {
    {	# case
	if (/^d/) {
	    $dseen++;
	    chop($_ = &q(<<'EOT'));
:	<<--#ifdef PRINTIT
:	$printit = 0;
:	<<--#endif
:	next LINE;
EOT
	    $sawnext++;
	    next;
	}

	if (/^n/) {
	    chop($_ = &q(<<'EOT'));
:	<<--#ifdef PRINTIT
:	<<--#ifdef DSEEN
:	<<--#ifdef ASSUMEP
:	print if $printit++;
:	<<--#else
:	if ($printit)
:	    { print; }
:	else
:	    { $printit++ unless $nflag; }
:	<<--#endif
:	<<--#else
:	print if $printit;
:	<<--#endif
:	<<--#else
:	print;
:	<<--#endif
:	<<--#ifdef APPENDSEEN
:	if ($atext) {chop $atext; print $atext; $atext = '';}
:	<<--#endif
:	$_ = <>;
:	chop;
:	<<--#ifdef TSEEN
:	$tflag = 0;
:	<<--#endif
EOT
	    next;
	}

	if (/^a/) {
	    $appendseen++;
	    $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
	    $lastline = 0;
	    while (<>) {
		s/^[ \t]*//;
		s/^[\\]//;
		unless (s|\\$||) { $lastline = 1;}
		s/^([ \t]*\n)/<><>$1/;
		$command .= $_;
		$command .= '<<--';
		last if $lastline;
	    }
	    $_ = $command . "End_Of_Text";
	    last;
	}

	if (/^[ic]/) {
	    if (/^c/) { $change = 1; }
	    $addr1 = 1 if $addr1 eq '';
	    $addr1 = '$iter = (' . $addr1 . ')';
	    $command = $space .
	      "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
	    $lastline = 0;
	    while (<>) {
		s/^[ \t]*//;
		s/^[\\]//;
		unless (s/\\$//) { $lastline = 1;}
		s/'/\\'/g;
		s/^([ \t]*\n)/<><>$1/;
		$command .= $_;
		$command .= '<<--';
		last if $lastline;
	    }
	    $_ = $command . "End_Of_Text";
	    if ($change) {
		$dseen++;
		$change = "$_\n";
		chop($_ = &q(<<"EOT"));
:	<<--#ifdef PRINTIT
:	$space\$printit = 0;
:	<<--#endif
:	${space}next LINE;
EOT
		$sawnext++;
	    }
	    last;
	}

	if (/^s/) {
	    $delim = substr($_,1,1);
	    $len = length($_);
	    $repl = $end = 0;
	    $inbracket = 0;
	    for ($i = 2; $i < $len; $i++) {
		$c = substr($_,$i,1);
		if ($c eq $delim) {
		    if ($inbracket) {
			substr($_, $i, 0) = '\\';
			$i++;
			$len++;
		    }
		    else {
			if ($repl) {
			    $end = $i;
			    last;
			} else {
			    $repl = $i;
			}
		    }
		}
		elsif ($c eq '\\') {
		    $i++;
		    if ($i >= $len) {
			$_ .= 'n';
			$_ .= <>;
			$len = length($_);
			$_ = substr($_,0,--$len);
		    }
		    elsif (substr($_,$i,1) =~ /^[n]$/) {
			;
		    }
		    elsif (!$repl &&
		      substr($_,$i,1) =~ /^[(){}\w]$/) {
			$i--;
			$len--;
			substr($_, $i, 1) = '';
		    }
		    elsif (!$repl &&
		      substr($_,$i,1) =~ /^[<>]$/) {
			substr($_,$i,1) = 'b';
		    }
		    elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
			substr($_,$i-1,1) = '$';
		    }
		}
		elsif ($c eq '&' && $repl) {
		    substr($_, $i, 0) = '$';
		    $i++;
		    $len++;
		}
		elsif ($c eq '$' && $repl) {
		    substr($_, $i, 0) = '\\';
		    $i++;
		    $len++;
		}
		elsif ($c eq '[' && !$repl) {
		    $i++ if substr($_,$i,1) eq '^';
		    $i++ if substr($_,$i,1) eq ']';
		    $inbracket = 1;
		}
		elsif ($c eq ']') {
		    $inbracket = 0;
		}
		elsif ($c eq "\t") {
		    substr($_, $i, 1) = '\\t';
		    $i++;
		    $len++;
		}
		elsif (!$repl && index("()+",$c) >= 0) {
		    substr($_, $i, 0) = '\\';
		    $i++;
		    $len++;
		}
	    }
	    &Die("Malformed substitution at line $.\n")
	      unless $end;
	    $pat = substr($_, 0, $repl + 1);
	    $repl = substr($_, $repl+1, $end-$repl-1);
	    $end = substr($_, $end + 1, 1000);
	    &simplify($pat);
	    $dol = '$';
	    $subst = "$pat$repl$delim";
	    $cmd = '';
	    while ($end) {
		if ($end =~ s/^g//) {
		    $subst .= 'g';
		    next;
		}
		if ($end =~ s/^p//) {
		    $cmd .= ' && (print)';
		    next;
		}
		if ($end =~ s/^w[ \t]*//) {
		    $fh = &make_filehandle($end);
		    $cmd .= " && (print $fh \$_)";
		    $end = '';
		    next;
		}
		&Die("Unrecognized substitution command".
		  "($end) at line $.\n");
	    }
	    chop ($_ = &q(<<"EOT"));
:	<<--#ifdef TSEEN
:	$subst && \$tflag++$cmd;
:	<<--#else
:	$subst$cmd;
:	<<--#endif
EOT
	    next;
	}

	if (/^p/) {
	    $_ = 'print;';
	    next;
	}

	if (/^w/) {
	    s/^w[ \t]*//;
	    $fh = &make_filehandle($_);
	    $_ = "print $fh \$_;";
	    next;
	}

	if (/^r/) {
	    $appendseen++;
	    s/^r[ \t]*//;
	    $file = $_;
	    $_ = "\$atext .= `cat $file 2>/dev/null`;";
	    next;
	}

	if (/^P/) {
	    $_ = 'print $1 if /^(.*)/;';
	    next;
	}

	if (/^D/) {
	    chop($_ = &q(<<'EOT'));
:	s/^.*\n?//;
:	redo LINE if $_;
:	next LINE;
EOT
	    $sawnext++;
	    next;
	}

	if (/^N/) {
	    chop($_ = &q(<<'EOT'));
:	$_ .= "\n";
:	$len1 = length;
:	$_ .= <>;
:	chop if $len1 < length;
:	<<--#ifdef TSEEN
:	$tflag = 0;
:	<<--#endif
EOT
	    next;
	}

	if (/^h/) {
	    $_ = '$hold = $_;';
	    next;
	}

	if (/^H/) {
	    $_ = '$hold .= "\n"; $hold .= $_;';
	    next;
	}

	if (/^g/) {
	    $_ = '$_ = $hold;';
	    next;
	}

	if (/^G/) {
	    $_ = '$_ .= "\n"; $_ .= $hold;';
	    next;
	}

	if (/^x/) {
	    $_ = '($_, $hold) = ($hold, $_);';
	    next;
	}

	if (/^b$/) {
	    $_ = 'next LINE;';
	    $sawnext++;
	    next;
	}

	if (/^b/) {
	    s/^b[ \t]*//;
	    $lab = &make_label($_);
	    if ($lab eq $toplabel) {
		$_ = 'redo LINE;';
	    } else {
		$_ = "goto $lab;";
	    }
	    next;
	}

	if (/^t$/) {
	    $_ = 'next LINE if $tflag;';
	    $sawnext++;
	    $tseen++;
	    next;
	}

	if (/^t/) {
	    s/^t[ \t]*//;
	    $lab = &make_label($_);
	    $_ = q/if ($tflag) {$tflag = 0; /;
	    if ($lab eq $toplabel) {
		$_ .= 'redo LINE;}';
	    } else {
		$_ .= "goto $lab;}";
	    }
	    $tseen++;
	    next;
	}

	if (/^y/) {
	    s/abcdefghijklmnopqrstuvwxyz/a-z/g;
	    s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
	    s/abcdef/a-f/g;
	    s/ABCDEF/A-F/g;
	    s/0123456789/0-9/g;
	    s/01234567/0-7/g;
	    $_ .= ';';
	}

	if (/^=/) {
	    $_ = 'print $.;';
	    next;
	}

	if (/^q/) {
	    chop($_ = &q(<<'EOT'));
:	close(ARGV);
:	@ARGV = ();
:	next LINE;
EOT
	    $sawnext++;
	    next;
	}
    } continue {
	if ($space) {
	    s/^/$space/;
	    s/(\n)(.)/$1$space$2/g;
	}
	last;
    }
    $_;
}

sub fetchpat {
    local($outer) = @_;
    local($addr) = $outer;
    local($inbracket);
    local($prefix,$delim,$ch);

    # Process pattern one potential delimiter at a time.

    DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
	$prefix = $1;
	$delim = $2;
	if ($delim eq '\\') {
	    s/(.)//;
	    $ch = $1;
	    $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
	    $ch = 'b' if $ch =~ /^[<>]$/;
	    $delim .= $ch;
	}
	elsif ($delim eq '[') {
	    $inbracket = 1;
	    s/^\^// && ($delim .= '^');
	    s/^]// && ($delim .= ']');
	}
	elsif ($delim eq ']') {
	    $inbracket = 0;
	}
	elsif ($inbracket || $delim ne $outer) {
	    $delim = '\\' . $delim;
	}
	$addr .= $prefix;
	$addr .= $delim;
	if ($delim eq $outer && !$inbracket) {
	    last DELIM;
	}
    }
    $addr =~ s/\t/\\t/g;
    &simplify($addr);
    $addr;
}

sub q {
    local($string) = @_;
    local($*) = 1;
    $string =~ s/^:\t?//g;
    $string;
}

sub simplify {
    $_[0] =~ s/_a-za-z0-9/\\w/ig;
    $_[0] =~ s/a-z_a-z0-9/\\w/ig;
    $_[0] =~ s/a-za-z_0-9/\\w/ig;
    $_[0] =~ s/a-za-z0-9_/\\w/ig;
    $_[0] =~ s/_0-9a-za-z/\\w/ig;
    $_[0] =~ s/0-9_a-za-z/\\w/ig;
    $_[0] =~ s/0-9a-z_a-z/\\w/ig;
    $_[0] =~ s/0-9a-za-z_/\\w/ig;
    $_[0] =~ s/\[\\w\]/\\w/g;
    $_[0] =~ s/\[^\\w\]/\\W/g;
    $_[0] =~ s/\[0-9\]/\\d/g;
    $_[0] =~ s/\[^0-9\]/\\D/g;
    $_[0] =~ s/\\d\\d\*/\\d+/g;
    $_[0] =~ s/\\D\\D\*/\\D+/g;
    $_[0] =~ s/\\w\\w\*/\\w+/g;
    $_[0] =~ s/\\t\\t\*/\\t+/g;
    $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
    $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
}

!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
Commit	Line	Data
4633a7c4	1	#!/usr/local/bin/perl
	2
	3	use Config;
	4	use File::Basename qw(&basename &dirname);
	5
	6	# List explicitly here the variables you want Configure to
	7	# generate. Metaconfig only looks for shell variables, so you
	8	# have to mention them as if they were shell variables, not
	9	# %Config entries. Thus you write
	10	# $startperl
	11	# to ensure Configure will look for $Config{startperl}.
	12
	13	# This forces PL files to create target in same directory as PL file.
	14	# This is so that make depend always knows where to find PL derivatives.
	15	chdir(dirname($0));
	16	($file = basename($0)) =~ s/\.PL$//;
	17	$file =~ s/\.pl$//
f360dba1	18	if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
4633a7c4	19
	20	open OUT,">$file" or die "Can't create $file: $!";
	21
	22	print "Extracting $file (with variable substitutions)\n";
	23
	24	# In this section, perl variables will be expanded during extraction.
	25	# You can use $Config{...} to use Configure variables.
	26
	27	print OUT <<"!GROK!THIS!";
	28	$Config{'startperl'}
	29	eval 'exec perl -S \$0 "\$@"'
	30	if 0;
f70b6ff5	31	\$startperl = "$Config{startperl}";
a687059c	32	!GROK!THIS!
a687059c	33
4633a7c4	34	# In the following, perl variables are not expanded during extraction.
	35
	36	print OUT <<'!NO!SUBS!';
a687059c	37
79072805	38	# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
378cc40b	39	#
a687059c	40	# $Log: s2p.SH,v $
8d063cd8	41
d83e3bda	42	=head1 NAME
	43
	44	s2p - Sed to Perl translator
	45
	46	=head1 SYNOPSIS
	47
	48	B<s2p [options] filename>
	49
	50	=head1 DESCRIPTION
	51
	52	I<S2p> takes a sed script specified on the command line (or from
	53	standard input) and produces a comparable I<perl> script on the
	54	standard output.
	55
	56	=head2 Options
	57
	58	Options include:
	59
	60	=over 5
	61
	62	=item B<-DE<lt>numberE<gt>>
	63
	64	sets debugging flags.
	65
	66	=item B<-n>
	67
	68	specifies that this sed script was always invoked with a B<sed -n>.
	69	Otherwise a switch parser is prepended to the front of the script.
	70
	71	=item B<-p>
	72
	73	specifies that this sed script was never invoked with a B<sed -n>.
	74	Otherwise a switch parser is prepended to the front of the script.
	75
	76	=back
	77
	78	=head2 Considerations
	79
	80	The perl script produced looks very sed-ish, and there may very well
	81	be better ways to express what you want to do in perl. For instance,
	82	s2p does not make any use of the split operator, but you might want
	83	to.
	84
	85	The perl script you end up with may be either faster or slower than
	86	the original sed script. If you're only interested in speed you'll
	87	just have to try it both ways. Of course, if you want to do something
	88	sed doesn't do, you have no choice. It's often possible to speed up
	89	the perl script by various methods, such as deleting all references to
	90	$\ and chop.
	91
	92	=head1 ENVIRONMENT
	93
	94	S2p uses no environment variables.
	95
	96	=head1 AUTHOR
	97
	98	Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt>
	99
	100	=head1 FILES
	101
	102	=head1 SEE ALSO
	103
	104	perl The perl compiler/interpreter
	105
106	a2p awk to perl translator
107
108	=head1 DIAGNOSTICS
109
110	=head1 BUGS
111
112	=cut
113
8d063cd8	114	$indent = 4;
	115	$shiftwidth = 4;
	116	$l = '{'; $r = '}';
8d063cd8	117
0a12ae7d	118	while ($ARGV[0] =~ /^-/) {
8d063cd8	119	$_ = shift;
	120	last if /^--/;
	121	if (/^-D/) {
	122	$debug++;
0a12ae7d	123	open(BODY,'>-');
8d063cd8	124	next;
	125	}
	126	if (/^-n/) {
	127	$assumen++;
	128	next;
	129	}
	130	if (/^-p/) {
	131	$assumep++;
	132	next;
	133	}
378cc40b	134	die "I don't recognize this switch: $_\n";
8d063cd8	135	}
	136
	137	unless ($debug) {
0a12ae7d	138	open(BODY,">/tmp/sperl$$") \|\|
0a12ae7d	139	&Die("Can't open temp file: $!\n");
8d063cd8	140	}
	141
	142	if (!$assumen && !$assumep) {
9ef589d8	143	print BODY &q(<<'EOT');
	144	: while ($ARGV[0] =~ /^-/) {
	145	: $_ = shift;
	146	: last if /^--/;
	147	: if (/^-n/) {
	148	: $nflag++;
	149	: next;
	150	: }
	151	: die "I don't recognize this switch: $_\\n";
	152	: }
	153	:
0a12ae7d	154	EOT
8d063cd8	155	}
8d063cd8	156
9ef589d8	157	print BODY &q(<<'EOT');
	158	: #ifdef PRINTIT
	159	: #ifdef ASSUMEP
	160	: $printit++;
	161	: #else
	162	: $printit++ unless $nflag;
	163	: #endif
	164	: #endif
	165	: <><>
	166	: $\ = "\n"; # automatically add newline on print
	167	: <><>
	168	: #ifdef TOPLABEL
	169	: LINE:
	170	: while (chop($_ = <>)) {
	171	: #else
	172	: LINE:
	173	: while (<>) {
	174	: chop;
	175	: #endif
0a12ae7d	176	EOT
0a12ae7d	177
9ef589d8	178	LINE:
9ef589d8	179	while (<>) {
0a12ae7d	180
0a12ae7d	181	# Wipe out surrounding whitespace.
8d063cd8	182
8d063cd8	183	s/[ \t](.)\n$/$1/;
0a12ae7d	184
	185	# Perhaps it's a label/comment.
	186
8d063cd8	187	if (/^:/) {
8d063cd8	188	s/^:[ \t]*//;
0a12ae7d	189	$label = &make_label($_);
8d063cd8	190	if ($. == 1) {
8d063cd8	191	$toplabel = $label;
9ef589d8	192	if (/^(top\|(re)?start\|redo\|begin(ning)\|again\|input)$/i) {
	193	$_ = <>;
	194	redo LINE; # Never referenced, so delete it if not a comment.
	195	}
8d063cd8	196	}
8d063cd8	197	$_ = "$label:";
ffed7fef	198	if ($lastlinewaslabel++) {
ffed7fef	199	$indent += 4;
0a12ae7d	200	print BODY &tab, ";\n";
ffed7fef	201	$indent -= 4;
ffed7fef	202	}
8d063cd8	203	if ($indent >= 2) {
	204	$indent -= 2;
	205	$indmod = 2;
	206	}
	207	next;
	208	} else {
	209	$lastlinewaslabel = '';
	210	}
0a12ae7d	211
	212	# Look for one or two address clauses
	213
8d063cd8	214	$addr1 = '';
	215	$addr2 = '';
	216	if (s/^([0-9]+)//) {
	217	$addr1 = "$1";
9ef589d8	218	$addr1 = "\$. == $addr1" unless /^,/;
8d063cd8	219	}
	220	elsif (s/^\$//) {
	221	$addr1 = 'eof()';
	222	}
	223	elsif (s\|^/\|\|) {
0a12ae7d	224	$addr1 = &fetchpat('/');
8d063cd8	225	}
	226	if (s/^,//) {
	227	if (s/^([0-9]+)//) {
	228	$addr2 = "$1";
	229	} elsif (s/^\$//) {
	230	$addr2 = "eof()";
	231	} elsif (s\|^/\|\|) {
0a12ae7d	232	$addr2 = &fetchpat('/');
8d063cd8	233	} else {
0a12ae7d	234	&Die("Invalid second address at line $.\n");
8d063cd8	235	}
2b69d0c2	236	if ($addr2 =~ /^\d+$/) {
	237	$addr1 .= "..$addr2";
	238	}
	239	else {
	240	$addr1 .= "...$addr2";
	241	}
8d063cd8	242	}
0a12ae7d	243
	244	# Now we check for metacommands {, }, and ! and worry
	245	# about indentation.
	246
378cc40b	247	s/^[ \t]+//;
0a12ae7d	248	# a { to keep vi happy
8d063cd8	249	if ($_ eq '}') {
	250	$indent -= 4;
	251	next;
	252	}
	253	if (s/^!//) {
	254	$if = 'unless';
	255	$else = "$r else $l\n";
	256	} else {
	257	$if = 'if';
	258	$else = '';
	259	}
	260	if (s/^{//) { # a } to keep vi happy
	261	$indmod = 4;
	262	$redo = $_;
	263	$_ = '';
	264	$rmaybe = '';
	265	} else {
	266	$rmaybe = "\n$r";
	267	if ($addr2 \|\| $addr1) {
a687059c	268	$space = ' ' x $shiftwidth;
8d063cd8	269	} else {
	270	$space = '';
	271	}
0a12ae7d	272	$_ = &transmogrify();
8d063cd8	273	}
8d063cd8	274
0a12ae7d	275	# See if we can optimize to modifier form.
0a12ae7d	276
8d063cd8	277	if ($addr1) {
	278	if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
	279	$_ !~ / if / && $_ !~ / unless /) {
	280	s/;$/ $if $addr1;/;
	281	$_ = substr($_,$shiftwidth,1000);
	282	} else {
0a12ae7d	283	$_ = "$if ($addr1) $l\n$change$_$rmaybe";
8d063cd8	284	}
8d063cd8	285	$change = '';
0a12ae7d	286	next LINE;
8d063cd8	287	}
	288	} continue {
	289	@lines = split(/\n/,$_);
0a12ae7d	290	for (@lines) {
8d063cd8	291	unless (s/^ *<<--//) {
0a12ae7d	292	print BODY &tab;
8d063cd8	293	}
0a12ae7d	294	print BODY $_, "\n";
8d063cd8	295	}
	296	$indent += $indmod;
	297	$indmod = 0;
	298	if ($redo) {
	299	$_ = $redo;
	300	$redo = '';
0a12ae7d	301	redo LINE;
8d063cd8	302	}
8d063cd8	303	}
ffed7fef	304	if ($lastlinewaslabel++) {
ffed7fef	305	$indent += 4;
0a12ae7d	306	print BODY &tab, ";\n";
ffed7fef	307	$indent -= 4;
ffed7fef	308	}
8d063cd8	309
8d063cd8	310	if ($appendseen \|\| $tseen \|\| !$assumen) {
8d063cd8	311	$printit++ if $dseen \|\| (!$assumen && !$assumep);
9ef589d8	312	print BODY &q(<<'EOT');
	313	: #ifdef SAWNEXT
	314	: }
	315	: continue {
	316	: #endif
	317	: #ifdef PRINTIT
	318	: #ifdef DSEEN
	319	: #ifdef ASSUMEP
	320	: print if $printit++;
	321	: #else
	322	: if ($printit)
	323	: { print; }
	324	: else
	325	: { $printit++ unless $nflag; }
	326	: #endif
	327	: #else
	328	: print if $printit;
	329	: #endif
	330	: #else
	331	: print;
	332	: #endif
	333	: #ifdef TSEEN
	334	: $tflag = 0;
	335	: #endif
	336	: #ifdef APPENDSEEN
	337	: if ($atext) { chop $atext; print $atext; $atext = ''; }
	338	: #endif
	339	EOT
	340
	341	print BODY &q(<<'EOT');
	342	: }
0a12ae7d	343	EOT
8d063cd8	344	}
8d063cd8	345
0a12ae7d	346	close BODY;
8d063cd8	347
8d063cd8	348	unless ($debug) {
0a12ae7d	349	open(HEAD,">/tmp/sperl2$$.c")
0a12ae7d	350	\|\| &Die("Can't open temp file 2: $!\n");
9ef589d8	351	print HEAD "#define PRINTIT\n" if $printit;
	352	print HEAD "#define APPENDSEEN\n" if $appendseen;
	353	print HEAD "#define TSEEN\n" if $tseen;
	354	print HEAD "#define DSEEN\n" if $dseen;
	355	print HEAD "#define ASSUMEN\n" if $assumen;
	356	print HEAD "#define ASSUMEP\n" if $assumep;
	357	print HEAD "#define TOPLABEL\n" if $toplabel;
	358	print HEAD "#define SAWNEXT\n" if $sawnext;
0a12ae7d	359	if ($opens) {print HEAD "$opens\n";}
	360	open(BODY,"/tmp/sperl$$")
	361	\|\| &Die("Can't reopen temp file: $!\n");
	362	while (<BODY>) {
	363	print HEAD $_;
8d063cd8	364	}
0a12ae7d	365	close HEAD;
8d063cd8	366
9ef589d8	367	print &q(<<"EOT");
4633a7c4	368	: $startperl
4633a7c4	369	: eval 'exec perl -S \$0 \${1+"\$@"}'
9ef589d8	370	: if \$running_under_some_shell;
9ef589d8	371	:
0a12ae7d	372	EOT
	373	open(BODY,"cc -E /tmp/sperl2$$.c \|") \|\|
	374	&Die("Can't reopen temp file: $!\n");
	375	while (<BODY>) {
8d063cd8	376	/^# [0-9]/ && next;
	377	/^[ \t]*$/ && next;
	378	s/^<><>//;
	379	print;
	380	}
	381	}
	382
0a12ae7d	383	&Cleanup;
0a12ae7d	384	exit;
8d063cd8	385
0a12ae7d	386	sub Cleanup {
	387	chdir "/tmp";
	388	unlink "sperl$$", "sperl2$$", "sperl2$$.c";
	389	}
8d063cd8	390	sub Die {
0a12ae7d	391	&Cleanup;
8d063cd8	392	die $_[0];
8d063cd8	393	}
0a12ae7d	394	sub tab {
	395	"\t" x ($indent / 8) . ' ' x ($indent % 8);
	396	}
8d063cd8	397	sub make_filehandle {
0a12ae7d	398	local($_) = $_[0];
0a12ae7d	399	local($fname) = $_;
9ef589d8	400	if (!$seen{$fname}) {
	401	$_ = "FH_" . $_ if /^\d/;
	402	s/[^a-zA-Z0-9]/_/g;
	403	s/^_*//;
	404	$_ = "\U$_";
	405	if ($fhseen{$_}) {
	406	for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
	407	$_ .= $tmp;
	408	}
	409	$fhseen{$_} = 1;
	410	$opens .= &q(<<"EOT");
	411	: open($_, '>$fname') \|\| die "Can't create $fname: \$!";
0a12ae7d	412	EOT
9ef589d8	413	$seen{$fname} = $_;
8d063cd8	414	}
9ef589d8	415	$seen{$fname};
8d063cd8	416	}
	417
	418	sub make_label {
0a12ae7d	419	local($label) = @_;
8d063cd8	420	$label =~ s/[^a-zA-Z0-9]/_/g;
	421	if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
	422	$label = substr($label,0,8);
0a12ae7d	423
	424	# Could be a reserved word, so capitalize it.
	425	substr($label,0,1) =~ y/a-z/A-Z/
	426	if $label =~ /^[a-z]/;
	427
8d063cd8	428	$label;
	429	}
	430
	431	sub transmogrify {
	432	{ # case
	433	if (/^d/) {
	434	$dseen++;
9ef589d8	435	chop($_ = &q(<<'EOT'));
	436	: <<--#ifdef PRINTIT
	437	: $printit = 0;
	438	: <<--#endif
	439	: next LINE;
0a12ae7d	440	EOT
9ef589d8	441	$sawnext++;
8d063cd8	442	next;
	443	}
	444
	445	if (/^n/) {
9ef589d8	446	chop($_ = &q(<<'EOT'));
	447	: <<--#ifdef PRINTIT
	448	: <<--#ifdef DSEEN
	449	: <<--#ifdef ASSUMEP
	450	: print if $printit++;
	451	: <<--#else
	452	: if ($printit)
	453	: { print; }
	454	: else
	455	: { $printit++ unless $nflag; }
	456	: <<--#endif
	457	: <<--#else
	458	: print if $printit;
	459	: <<--#endif
	460	: <<--#else
	461	: print;
	462	: <<--#endif
	463	: <<--#ifdef APPENDSEEN
	464	: if ($atext) {chop $atext; print $atext; $atext = '';}
	465	: <<--#endif
	466	: $_ = <>;
	467	: chop;
	468	: <<--#ifdef TSEEN
	469	: $tflag = 0;
	470	: <<--#endif
0a12ae7d	471	EOT
8d063cd8	472	next;
	473	}
	474
	475	if (/^a/) {
	476	$appendseen++;
9ef589d8	477	$command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
8d063cd8	478	$lastline = 0;
	479	while (<>) {
	480	s/^[ \t]*//;
	481	s/^[\\]//;
	482	unless (s\|\\$\|\|) { $lastline = 1;}
8d063cd8	483	s/^([ \t]*\n)/<><>$1/;
	484	$command .= $_;
	485	$command .= '<<--';
	486	last if $lastline;
	487	}
9ef589d8	488	$_ = $command . "End_Of_Text";
8d063cd8	489	last;
	490	}
	491
	492	if (/^[ic]/) {
	493	if (/^c/) { $change = 1; }
9ef589d8	494	$addr1 = 1 if $addr1 eq '';
8d063cd8	495	$addr1 = '$iter = (' . $addr1 . ')';
9ef589d8	496	$command = $space .
9ef589d8	497	" if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
8d063cd8	498	$lastline = 0;
	499	while (<>) {
	500	s/^[ \t]*//;
	501	s/^[\\]//;
	502	unless (s/\\$//) { $lastline = 1;}
	503	s/'/\\'/g;
	504	s/^([ \t]*\n)/<><>$1/;
	505	$command .= $_;
	506	$command .= '<<--';
	507	last if $lastline;
	508	}
9ef589d8	509	$_ = $command . "End_Of_Text";
8d063cd8	510	if ($change) {
	511	$dseen++;
	512	$change = "$_\n";
9ef589d8	513	chop($_ = &q(<<"EOT"));
	514	: <<--#ifdef PRINTIT
	515	: $space\$printit = 0;
	516	: <<--#endif
	517	: ${space}next LINE;
0a12ae7d	518	EOT
9ef589d8	519	$sawnext++;
8d063cd8	520	}
	521	last;
	522	}
	523
	524	if (/^s/) {
	525	$delim = substr($_,1,1);
	526	$len = length($_);
	527	$repl = $end = 0;
a687059c	528	$inbracket = 0;
8d063cd8	529	for ($i = 2; $i < $len; $i++) {
8d063cd8	530	$c = substr($_,$i,1);
a687059c	531	if ($c eq $delim) {
a687059c	532	if ($inbracket) {
0a12ae7d	533	substr($_, $i, 0) = '\\';
a687059c	534	$i++;
	535	$len++;
	536	}
	537	else {
	538	if ($repl) {
	539	$end = $i;
	540	last;
	541	} else {
	542	$repl = $i;
	543	}
	544	}
	545	}
	546	elsif ($c eq '\\') {
8d063cd8	547	$i++;
	548	if ($i >= $len) {
	549	$_ .= 'n';
	550	$_ .= <>;
	551	$len = length($_);
	552	$_ = substr($_,0,--$len);
	553	}
00bf170e	554	elsif (substr($_,$i,1) =~ /^[n]$/) {
	555	;
	556	}
0a12ae7d	557	elsif (!$repl &&
0a12ae7d	558	substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8	559	$i--;
8d063cd8	560	$len--;
0a12ae7d	561	substr($_, $i, 1) = '';
8d063cd8	562	}
0a12ae7d	563	elsif (!$repl &&
0a12ae7d	564	substr($_,$i,1) =~ /^[<>]$/) {
9f68db38	565	substr($_,$i,1) = 'b';
9f68db38	566	}
2b69d0c2	567	elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
	568	substr($_,$i-1,1) = '$';
	569	}
	570	}
	571	elsif ($c eq '&' && $repl) {
	572	substr($_, $i, 0) = '$';
	573	$i++;
	574	$len++;
	575	}
	576	elsif ($c eq '$' && $repl) {
	577	substr($_, $i, 0) = '\\';
	578	$i++;
	579	$len++;
8d063cd8	580	}
a687059c	581	elsif ($c eq '[' && !$repl) {
	582	$i++ if substr($_,$i,1) eq '^';
	583	$i++ if substr($_,$i,1) eq ']';
	584	$inbracket = 1;
8d063cd8	585	}
a687059c	586	elsif ($c eq ']') {
	587	$inbracket = 0;
	588	}
9ef589d8	589	elsif ($c eq "\t") {
	590	substr($_, $i, 1) = '\\t';
	591	$i++;
	592	$len++;
	593	}
ae986130	594	elsif (!$repl && index("()+",$c) >= 0) {
0a12ae7d	595	substr($_, $i, 0) = '\\';
8d063cd8	596	$i++;
	597	$len++;
	598	}
	599	}
0a12ae7d	600	&Die("Malformed substitution at line $.\n")
0a12ae7d	601	unless $end;
8d063cd8	602	$pat = substr($_, 0, $repl + 1);
0a12ae7d	603	$repl = substr($_, $repl+1, $end-$repl-1);
8d063cd8	604	$end = substr($_, $end + 1, 1000);
9ef589d8	605	&simplify($pat);
8d063cd8	606	$dol = '$';
8d063cd8	607	$subst = "$pat$repl$delim";
	608	$cmd = '';
	609	while ($end) {
0a12ae7d	610	if ($end =~ s/^g//) {
	611	$subst .= 'g';
	612	next;
	613	}
	614	if ($end =~ s/^p//) {
	615	$cmd .= ' && (print)';
	616	next;
	617	}
8d063cd8	618	if ($end =~ s/^w[ \t]*//) {
0a12ae7d	619	$fh = &make_filehandle($end);
8d063cd8	620	$cmd .= " && (print $fh \$_)";
	621	$end = '';
	622	next;
	623	}
0a12ae7d	624	&Die("Unrecognized substitution command".
0a12ae7d	625	"($end) at line $.\n");
8d063cd8	626	}
9ef589d8	627	chop ($_ = &q(<<"EOT"));
	628	: <<--#ifdef TSEEN
	629	: $subst && \$tflag++$cmd;
	630	: <<--#else
	631	: $subst$cmd;
	632	: <<--#endif
0a12ae7d	633	EOT
8d063cd8	634	next;
	635	}
	636
	637	if (/^p/) {
	638	$_ = 'print;';
	639	next;
	640	}
	641
	642	if (/^w/) {
	643	s/^w[ \t]*//;
0a12ae7d	644	$fh = &make_filehandle($_);
8d063cd8	645	$_ = "print $fh \$_;";
	646	next;
	647	}
	648
	649	if (/^r/) {
	650	$appendseen++;
	651	s/^r[ \t]*//;
	652	$file = $_;
	653	$_ = "\$atext .= `cat $file 2>/dev/null`;";
	654	next;
	655	}
	656
	657	if (/^P/) {
9ef589d8	658	$_ = 'print $1 if /^(.*)/;';
8d063cd8	659	next;
	660	}
	661
	662	if (/^D/) {
9ef589d8	663	chop($_ = &q(<<'EOT'));
	664	: s/^.*\n?//;
	665	: redo LINE if $_;
	666	: next LINE;
0a12ae7d	667	EOT
9ef589d8	668	$sawnext++;
8d063cd8	669	next;
	670	}
	671
	672	if (/^N/) {
9ef589d8	673	chop($_ = &q(<<'EOT'));
	674	: $_ .= "\n";
	675	: $len1 = length;
	676	: $_ .= <>;
	677	: chop if $len1 < length;
	678	: <<--#ifdef TSEEN
	679	: $tflag = 0;
	680	: <<--#endif
0a12ae7d	681	EOT
8d063cd8	682	next;
	683	}
	684
	685	if (/^h/) {
	686	$_ = '$hold = $_;';
	687	next;
	688	}
	689
	690	if (/^H/) {
9ef589d8	691	$_ = '$hold .= "\n"; $hold .= $_;';
8d063cd8	692	next;
	693	}
	694
	695	if (/^g/) {
	696	$_ = '$_ = $hold;';
	697	next;
	698	}
	699
	700	if (/^G/) {
9ef589d8	701	$_ = '$_ .= "\n"; $_ .= $hold;';
8d063cd8	702	next;
	703	}
	704
	705	if (/^x/) {
	706	$_ = '($_, $hold) = ($hold, $_);';
	707	next;
	708	}
	709
	710	if (/^b$/) {
0a12ae7d	711	$_ = 'next LINE;';
9ef589d8	712	$sawnext++;
8d063cd8	713	next;
	714	}
	715
	716	if (/^b/) {
	717	s/^b[ \t]*//;
0a12ae7d	718	$lab = &make_label($_);
8d063cd8	719	if ($lab eq $toplabel) {
0a12ae7d	720	$_ = 'redo LINE;';
8d063cd8	721	} else {
	722	$_ = "goto $lab;";
	723	}
	724	next;
	725	}
	726
	727	if (/^t$/) {
0a12ae7d	728	$_ = 'next LINE if $tflag;';
9ef589d8	729	$sawnext++;
8d063cd8	730	$tseen++;
	731	next;
	732	}
	733
	734	if (/^t/) {
	735	s/^t[ \t]*//;
0a12ae7d	736	$lab = &make_label($_);
9ef589d8	737	$_ = q/if ($tflag) {$tflag = 0; /;
8d063cd8	738	if ($lab eq $toplabel) {
0a12ae7d	739	$_ .= 'redo LINE;}';
8d063cd8	740	} else {
0a12ae7d	741	$_ .= "goto $lab;}";
8d063cd8	742	}
	743	$tseen++;
	744	next;
	745	}
	746
9ef589d8	747	if (/^y/) {
	748	s/abcdefghijklmnopqrstuvwxyz/a-z/g;
	749	s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
	750	s/abcdef/a-f/g;
	751	s/ABCDEF/A-F/g;
	752	s/0123456789/0-9/g;
	753	s/01234567/0-7/g;
	754	$_ .= ';';
	755	}
	756
8d063cd8	757	if (/^=/) {
9ef589d8	758	$_ = 'print $.;';
8d063cd8	759	next;
	760	}
	761
	762	if (/^q/) {
9ef589d8	763	chop($_ = &q(<<'EOT'));
	764	: close(ARGV);
	765	: @ARGV = ();
	766	: next LINE;
0a12ae7d	767	EOT
9ef589d8	768	$sawnext++;
8d063cd8	769	next;
	770	}
	771	} continue {
	772	if ($space) {
	773	s/^/$space/;
	774	s/(\n)(.)/$1$space$2/g;
	775	}
	776	last;
	777	}
	778	$_;
	779	}
	780
a687059c	781	sub fetchpat {
	782	local($outer) = @_;
	783	local($addr) = $outer;
	784	local($inbracket);
	785	local($prefix,$delim,$ch);
	786
0a12ae7d	787	# Process pattern one potential delimiter at a time.
	788
	789	DELIM: while (s#^([^\]+(\|)[\\/]*)([]+(\|)[\\/])##) {
a687059c	790	$prefix = $1;
a687059c	791	$delim = $2;
a687059c	792	if ($delim eq '\\') {
	793	s/(.)//;
	794	$ch = $1;
00bf170e	795	$delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
9f68db38	796	$ch = 'b' if $ch =~ /^[<>]$/;
9f68db38	797	$delim .= $ch;
a687059c	798	}
	799	elsif ($delim eq '[') {
	800	$inbracket = 1;
	801	s/^\^// && ($delim .= '^');
	802	s/^]// && ($delim .= ']');
a687059c	803	}
	804	elsif ($delim eq ']') {
	805	$inbracket = 0;
	806	}
	807	elsif ($inbracket \|\| $delim ne $outer) {
a687059c	808	$delim = '\\' . $delim;
	809	}
	810	$addr .= $prefix;
	811	$addr .= $delim;
	812	if ($delim eq $outer && !$inbracket) {
0a12ae7d	813	last DELIM;
a687059c	814	}
a687059c	815	}
9ef589d8	816	$addr =~ s/\t/\\t/g;
9ef589d8	817	&simplify($addr);
a687059c	818	$addr;
	819	}
	820
9ef589d8	821	sub q {
	822	local($string) = @_;
	823	local($*) = 1;
	824	$string =~ s/^:\t?//g;
	825	$string;
	826	}
	827
	828	sub simplify {
	829	$_[0] =~ s/_a-za-z0-9/\\w/ig;
	830	$_[0] =~ s/a-z_a-z0-9/\\w/ig;
	831	$_[0] =~ s/a-za-z_0-9/\\w/ig;
	832	$_[0] =~ s/a-za-z0-9_/\\w/ig;
	833	$_[0] =~ s/_0-9a-za-z/\\w/ig;
	834	$_[0] =~ s/0-9_a-za-z/\\w/ig;
	835	$_[0] =~ s/0-9a-z_a-z/\\w/ig;
	836	$_[0] =~ s/0-9a-za-z_/\\w/ig;
	837	$_[0] =~ s/\[\\w\]/\\w/g;
	838	$_[0] =~ s/\[^\\w\]/\\W/g;
	839	$_[0] =~ s/\[0-9\]/\\d/g;
	840	$_[0] =~ s/\[^0-9\]/\\D/g;
	841	$_[0] =~ s/\\d\\d\*/\\d+/g;
	842	$_[0] =~ s/\\D\\D\*/\\D+/g;
	843	$_[0] =~ s/\\w\\w\*/\\w+/g;
	844	$_[0] =~ s/\\t\\t\*/\\t+/g;
	845	$_[0] =~ s/(\[.[^]]\])\1\/$1+/g;
	846	$_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
	847	}
	848
a687059c	849	!NO!SUBS!
4633a7c4	850
	851	close OUT or die "Can't close $file: $!";
	852	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	853	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';