[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, '.PL');

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