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