[perl5.git] / x2p / s2p.PL

#!/usr/local/bin/perl

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

# 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.
$origdir = cwd;
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';

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

unless ($debug) {

    print &q(<<"EOT");
:	$startperl
:	eval 'exec $perlpath -S \$0 \${1+"\$@"}'
:		if \$running_under_some_shell;
:	
EOT
    print"$opens\n" if $opens;
    seek(BODY, 0, 0) || die "Can't rewind temp file: $!\n";
    while (<BODY>) {
	/^[ \t]*$/ && next;
	/^#ifdef (\w+)/ && ((${lc $1} || &skip), next);
	/^#else/ && (&skip, next);
	/^#endif/ && next;
	s/^<><>//;
	print;
    }
}

&Cleanup;
exit;

sub Cleanup {
    unlink "/tmp/sperl$$";
}
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);
	    $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;
}

sub skip {
    local($level) = 0;

    while(<BODY>) {
	/^#ifdef/ && $level++;
	/^#else/  && !$level && return;
	/^#endif/ && !$level-- && return;
    }

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