[p5sagit/p5-mst-13.2.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 '@') {
		    substr($_, $i, 0) = '\\';
		    $i++;
		    $len++;
		}
		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;
    $addr =~ s/\@/\\@/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	1	#!/usr/local/bin/perl
	2
	3	use Config;
	4	use File::Basename qw(&basename &dirname);
8a5546a1	5	use Cwd;
4633a7c4	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	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	34	!GROK!THIS!
a687059c	35
4633a7c4	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	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
3cb6de81	54	I<s2p> takes a sed script specified on the command line (or from
d83e3bda	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
3cb6de81	96	s2p uses no environment variables.
d83e3bda	97
	98	=head1 AUTHOR
	99
55497cff	100	Larry Wall E<lt>F<larry@wall.org>E<gt>
d83e3bda	101
	102	=head1 FILES
	103
	104	=head1 SEE ALSO
	105
	106	perl The perl compiler/interpreter
3cb6de81	107
d83e3bda	108	a2p awk to perl translator
	109
	110	=head1 DIAGNOSTICS
	111
	112	=head1 BUGS
	113
	114	=cut
	115
8d063cd8	116	$indent = 4;
	117	$shiftwidth = 4;
	118	$l = '{'; $r = '}';
8d063cd8	119
0a12ae7d	120	while ($ARGV[0] =~ /^-/) {
8d063cd8	121	$_ = shift;
	122	last if /^--/;
	123	if (/^-D/) {
	124	$debug++;
0a12ae7d	125	open(BODY,'>-');
8d063cd8	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	137	}
	138
	139	unless ($debug) {
1aa91729	140	open(BODY,"+>/tmp/sperl$$") \|\|
0a12ae7d	141	&Die("Can't open temp file: $!\n");
8d063cd8	142	}
	143
	144	if (!$assumen && !$assumep) {
9ef589d8	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	157	}
8d063cd8	158
9ef589d8	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	178	EOT
0a12ae7d	179
9ef589d8	180	LINE:
9ef589d8	181	while (<>) {
0a12ae7d	182
0a12ae7d	183	# Wipe out surrounding whitespace.
8d063cd8	184
8d063cd8	185	s/[ \t](.)\n$/$1/;
0a12ae7d	186
	187	# Perhaps it's a label/comment.
	188
8d063cd8	189	if (/^:/) {
8d063cd8	190	s/^:[ \t]*//;
0a12ae7d	191	$label = &make_label($_);
8d063cd8	192	if ($. == 1) {
8d063cd8	193	$toplabel = $label;
9ef589d8	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	198	}
8d063cd8	199	$_ = "$label:";
ffed7fef	200	if ($lastlinewaslabel++) {
ffed7fef	201	$indent += 4;
0a12ae7d	202	print BODY &tab, ";\n";
ffed7fef	203	$indent -= 4;
ffed7fef	204	}
8d063cd8	205	if ($indent >= 2) {
	206	$indent -= 2;
	207	$indmod = 2;
	208	}
	209	next;
	210	} else {
	211	$lastlinewaslabel = '';
	212	}
0a12ae7d	213
	214	# Look for one or two address clauses
	215
8d063cd8	216	$addr1 = '';
	217	$addr2 = '';
	218	if (s/^([0-9]+)//) {
	219	$addr1 = "$1";
9ef589d8	220	$addr1 = "\$. == $addr1" unless /^,/;
8d063cd8	221	}
	222	elsif (s/^\$//) {
	223	$addr1 = 'eof()';
	224	}
	225	elsif (s\|^/\|\|) {
0a12ae7d	226	$addr1 = &fetchpat('/');
8d063cd8	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	238	if ($addr2 =~ /^\d+$/) {
	239	$addr1 .= "..$addr2";
	240	}
	241	else {
	242	$addr1 .= "...$addr2";
	243	}
8d063cd8	244	}
0a12ae7d	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	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	271	} else {
	272	$space = '';
	273	}
0a12ae7d	274	$_ = &transmogrify();
8d063cd8	275	}
8d063cd8	276
0a12ae7d	277	# See if we can optimize to modifier form.
0a12ae7d	278
8d063cd8	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	286	}
8d063cd8	287	$change = '';
0a12ae7d	288	next LINE;
8d063cd8	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	297	}
	298	$indent += $indmod;
	299	$indmod = 0;
	300	if ($redo) {
	301	$_ = $redo;
	302	$redo = '';
0a12ae7d	303	redo LINE;
8d063cd8	304	}
8d063cd8	305	}
ffed7fef	306	if ($lastlinewaslabel++) {
ffed7fef	307	$indent += 4;
0a12ae7d	308	print BODY &tab, ";\n";
ffed7fef	309	$indent -= 4;
ffed7fef	310	}
8d063cd8	311
8d063cd8	312	if ($appendseen \|\| $tseen \|\| !$assumen) {
8d063cd8	313	$printit++ if $dseen \|\| (!$assumen && !$assumep);
9ef589d8	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	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	353	: if \$running_under_some_shell;
9ef589d8	354	:
0a12ae7d	355	EOT
1aa91729	356	print"$opens\n" if $opens;
1aa91729	357	seek(BODY, 0, 0) \|\| die "Can't rewind temp file: $!\n";
0a12ae7d	358	while (<BODY>) {
8d063cd8	359	/^[ \t]*$/ && next;
1aa91729	360	/^#ifdef (\w+)/ && ((${lc $1} \|\| &skip), next);
	361	/^#else/ && (&skip, next);
	362	/^#endif/ && next;
8d063cd8	363	s/^<><>//;
	364	print;
	365	}
	366	}
	367
0a12ae7d	368	&Cleanup;
0a12ae7d	369	exit;
8d063cd8	370
0a12ae7d	371	sub Cleanup {
1aa91729	372	unlink "/tmp/sperl$$";
0a12ae7d	373	}
8d063cd8	374	sub Die {
0a12ae7d	375	&Cleanup;
8d063cd8	376	die $_[0];
8d063cd8	377	}
0a12ae7d	378	sub tab {
	379	"\t" x ($indent / 8) . ' ' x ($indent % 8);
	380	}
8d063cd8	381	sub make_filehandle {
0a12ae7d	382	local($_) = $_[0];
0a12ae7d	383	local($fname) = $_;
9ef589d8	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	400	}
	401
	402	sub make_label {
0a12ae7d	403	local($label) = @_;
8d063cd8	404	$label =~ s/[^a-zA-Z0-9]/_/g;
	405	if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
	406	$label = substr($label,0,8);
0a12ae7d	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	412	$label;
	413	}
	414
	415	sub transmogrify {
	416	{ # case
	417	if (/^d/) {
	418	$dseen++;
9ef589d8	419	chop($_ = &q(<<'EOT'));
	420	: <<--#ifdef PRINTIT
	421	: $printit = 0;
	422	: <<--#endif
	423	: next LINE;
0a12ae7d	424	EOT
9ef589d8	425	$sawnext++;
8d063cd8	426	next;
	427	}
	428
	429	if (/^n/) {
9ef589d8	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	456	next;
	457	}
	458
	459	if (/^a/) {
	460	$appendseen++;
9ef589d8	461	$command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
8d063cd8	462	$lastline = 0;
	463	while (<>) {
	464	s/^[ \t]*//;
	465	s/^[\\]//;
	466	unless (s\|\\$\|\|) { $lastline = 1;}
8d063cd8	467	s/^([ \t]*\n)/<><>$1/;
	468	$command .= $_;
	469	$command .= '<<--';
	470	last if $lastline;
	471	}
9ef589d8	472	$_ = $command . "End_Of_Text";
8d063cd8	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	480	$command = $space .
9ef589d8	481	" if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
8d063cd8	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	494	if ($change) {
	495	$dseen++;
	496	$change = "$_\n";
9ef589d8	497	chop($_ = &q(<<"EOT"));
	498	: <<--#ifdef PRINTIT
	499	: $space\$printit = 0;
	500	: <<--#endif
	501	: ${space}next LINE;
0a12ae7d	502	EOT
9ef589d8	503	$sawnext++;
8d063cd8	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	513	for ($i = 2; $i < $len; $i++) {
8d063cd8	514	$c = substr($_,$i,1);
a687059c	515	if ($c eq $delim) {
a687059c	516	if ($inbracket) {
0a12ae7d	517	substr($_, $i, 0) = '\\';
a687059c	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	531	$i++;
	532	if ($i >= $len) {
	533	$_ .= 'n';
	534	$_ .= <>;
	535	$len = length($_);
	536	$_ = substr($_,0,--$len);
	537	}
00bf170e	538	elsif (substr($_,$i,1) =~ /^[n]$/) {
	539	;
	540	}
0a12ae7d	541	elsif (!$repl &&
0a12ae7d	542	substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8	543	$i--;
8d063cd8	544	$len--;
0a12ae7d	545	substr($_, $i, 1) = '';
8d063cd8	546	}
0a12ae7d	547	elsif (!$repl &&
0a12ae7d	548	substr($_,$i,1) =~ /^[<>]$/) {
9f68db38	549	substr($_,$i,1) = 'b';
9f68db38	550	}
2b69d0c2	551	elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
	552	substr($_,$i-1,1) = '$';
	553	}
	554	}
c602c2ef	555	elsif ($c eq '@') {
	556	substr($_, $i, 0) = '\\';
	557	$i++;
	558	$len++;
	559	}
2b69d0c2	560	elsif ($c eq '&' && $repl) {
	561	substr($_, $i, 0) = '$';
	562	$i++;
	563	$len++;
	564	}
	565	elsif ($c eq '$' && $repl) {
	566	substr($_, $i, 0) = '\\';
	567	$i++;
	568	$len++;
8d063cd8	569	}
a687059c	570	elsif ($c eq '[' && !$repl) {
	571	$i++ if substr($_,$i,1) eq '^';
	572	$i++ if substr($_,$i,1) eq ']';
	573	$inbracket = 1;
8d063cd8	574	}
a687059c	575	elsif ($c eq ']') {
	576	$inbracket = 0;
	577	}
9ef589d8	578	elsif ($c eq "\t") {
	579	substr($_, $i, 1) = '\\t';
	580	$i++;
	581	$len++;
	582	}
ae986130	583	elsif (!$repl && index("()+",$c) >= 0) {
0a12ae7d	584	substr($_, $i, 0) = '\\';
8d063cd8	585	$i++;
	586	$len++;
	587	}
	588	}
0a12ae7d	589	&Die("Malformed substitution at line $.\n")
0a12ae7d	590	unless $end;
8d063cd8	591	$pat = substr($_, 0, $repl + 1);
0a12ae7d	592	$repl = substr($_, $repl+1, $end-$repl-1);
8d063cd8	593	$end = substr($_, $end + 1, 1000);
9ef589d8	594	&simplify($pat);
8d063cd8	595	$subst = "$pat$repl$delim";
	596	$cmd = '';
	597	while ($end) {
0a12ae7d	598	if ($end =~ s/^g//) {
	599	$subst .= 'g';
	600	next;
	601	}
	602	if ($end =~ s/^p//) {
	603	$cmd .= ' && (print)';
	604	next;
	605	}
8d063cd8	606	if ($end =~ s/^w[ \t]*//) {
0a12ae7d	607	$fh = &make_filehandle($end);
8d063cd8	608	$cmd .= " && (print $fh \$_)";
	609	$end = '';
	610	next;
	611	}
0a12ae7d	612	&Die("Unrecognized substitution command".
0a12ae7d	613	"($end) at line $.\n");
8d063cd8	614	}
9ef589d8	615	chop ($_ = &q(<<"EOT"));
	616	: <<--#ifdef TSEEN
	617	: $subst && \$tflag++$cmd;
	618	: <<--#else
	619	: $subst$cmd;
	620	: <<--#endif
0a12ae7d	621	EOT
8d063cd8	622	next;
	623	}
	624
	625	if (/^p/) {
	626	$_ = 'print;';
	627	next;
	628	}
	629
	630	if (/^w/) {
	631	s/^w[ \t]*//;
0a12ae7d	632	$fh = &make_filehandle($_);
8d063cd8	633	$_ = "print $fh \$_;";
	634	next;
	635	}
	636
	637	if (/^r/) {
	638	$appendseen++;
	639	s/^r[ \t]*//;
	640	$file = $_;
	641	$_ = "\$atext .= `cat $file 2>/dev/null`;";
	642	next;
	643	}
	644
	645	if (/^P/) {
9ef589d8	646	$_ = 'print $1 if /^(.*)/;';
8d063cd8	647	next;
	648	}
	649
	650	if (/^D/) {
9ef589d8	651	chop($_ = &q(<<'EOT'));
	652	: s/^.*\n?//;
	653	: redo LINE if $_;
	654	: next LINE;
0a12ae7d	655	EOT
9ef589d8	656	$sawnext++;
8d063cd8	657	next;
	658	}
	659
	660	if (/^N/) {
9ef589d8	661	chop($_ = &q(<<'EOT'));
	662	: $_ .= "\n";
	663	: $len1 = length;
	664	: $_ .= <>;
	665	: chop if $len1 < length;
	666	: <<--#ifdef TSEEN
	667	: $tflag = 0;
	668	: <<--#endif
0a12ae7d	669	EOT
8d063cd8	670	next;
	671	}
	672
	673	if (/^h/) {
	674	$_ = '$hold = $_;';
	675	next;
	676	}
	677
	678	if (/^H/) {
d050a71c	679	$_ = '$hold .= "\n", $hold .= $_;';
8d063cd8	680	next;
	681	}
	682
	683	if (/^g/) {
	684	$_ = '$_ = $hold;';
	685	next;
	686	}
	687
	688	if (/^G/) {
d050a71c	689	$_ = '$_ .= "\n", $_ .= $hold;';
8d063cd8	690	next;
	691	}
	692
	693	if (/^x/) {
	694	$_ = '($_, $hold) = ($hold, $_);';
	695	next;
	696	}
	697
	698	if (/^b$/) {
0a12ae7d	699	$_ = 'next LINE;';
9ef589d8	700	$sawnext++;
8d063cd8	701	next;
	702	}
	703
	704	if (/^b/) {
	705	s/^b[ \t]*//;
0a12ae7d	706	$lab = &make_label($_);
8d063cd8	707	if ($lab eq $toplabel) {
0a12ae7d	708	$_ = 'redo LINE;';
8d063cd8	709	} else {
	710	$_ = "goto $lab;";
	711	}
	712	next;
	713	}
	714
	715	if (/^t$/) {
0a12ae7d	716	$_ = 'next LINE if $tflag;';
9ef589d8	717	$sawnext++;
8d063cd8	718	$tseen++;
	719	next;
	720	}
	721
	722	if (/^t/) {
	723	s/^t[ \t]*//;
0a12ae7d	724	$lab = &make_label($_);
9ef589d8	725	$_ = q/if ($tflag) {$tflag = 0; /;
8d063cd8	726	if ($lab eq $toplabel) {
0a12ae7d	727	$_ .= 'redo LINE;}';
8d063cd8	728	} else {
0a12ae7d	729	$_ .= "goto $lab;}";
8d063cd8	730	}
	731	$tseen++;
	732	next;
	733	}
	734
9ef589d8	735	if (/^y/) {
	736	s/abcdefghijklmnopqrstuvwxyz/a-z/g;
	737	s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
	738	s/abcdef/a-f/g;
	739	s/ABCDEF/A-F/g;
	740	s/0123456789/0-9/g;
	741	s/01234567/0-7/g;
	742	$_ .= ';';
	743	}
	744
8d063cd8	745	if (/^=/) {
9ef589d8	746	$_ = 'print $.;';
8d063cd8	747	next;
	748	}
	749
	750	if (/^q/) {
9ef589d8	751	chop($_ = &q(<<'EOT'));
	752	: close(ARGV);
	753	: @ARGV = ();
	754	: next LINE;
0a12ae7d	755	EOT
9ef589d8	756	$sawnext++;
8d063cd8	757	next;
	758	}
	759	} continue {
	760	if ($space) {
	761	s/^/$space/;
	762	s/(\n)(.)/$1$space$2/g;
	763	}
	764	last;
	765	}
	766	$_;
	767	}
	768
a687059c	769	sub fetchpat {
	770	local($outer) = @_;
	771	local($addr) = $outer;
	772	local($inbracket);
	773	local($prefix,$delim,$ch);
	774
0a12ae7d	775	# Process pattern one potential delimiter at a time.
	776
	777	DELIM: while (s#^([^\]+(\|)[\\/]*)([]+(\|)[\\/])##) {
a687059c	778	$prefix = $1;
a687059c	779	$delim = $2;
a687059c	780	if ($delim eq '\\') {
	781	s/(.)//;
	782	$ch = $1;
00bf170e	783	$delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
9f68db38	784	$ch = 'b' if $ch =~ /^[<>]$/;
9f68db38	785	$delim .= $ch;
a687059c	786	}
	787	elsif ($delim eq '[') {
	788	$inbracket = 1;
	789	s/^\^// && ($delim .= '^');
	790	s/^]// && ($delim .= ']');
a687059c	791	}
	792	elsif ($delim eq ']') {
	793	$inbracket = 0;
	794	}
	795	elsif ($inbracket \|\| $delim ne $outer) {
a687059c	796	$delim = '\\' . $delim;
	797	}
	798	$addr .= $prefix;
	799	$addr .= $delim;
	800	if ($delim eq $outer && !$inbracket) {
0a12ae7d	801	last DELIM;
a687059c	802	}
a687059c	803	}
9ef589d8	804	$addr =~ s/\t/\\t/g;
c602c2ef	805	$addr =~ s/\@/\\@/g;
9ef589d8	806	&simplify($addr);
a687059c	807	$addr;
	808	}
	809
9ef589d8	810	sub q {
	811	local($string) = @_;
	812	local($*) = 1;
	813	$string =~ s/^:\t?//g;
	814	$string;
	815	}
	816
	817	sub simplify {
	818	$_[0] =~ s/_a-za-z0-9/\\w/ig;
	819	$_[0] =~ s/a-z_a-z0-9/\\w/ig;
	820	$_[0] =~ s/a-za-z_0-9/\\w/ig;
	821	$_[0] =~ s/a-za-z0-9_/\\w/ig;
	822	$_[0] =~ s/_0-9a-za-z/\\w/ig;
	823	$_[0] =~ s/0-9_a-za-z/\\w/ig;
	824	$_[0] =~ s/0-9a-z_a-z/\\w/ig;
	825	$_[0] =~ s/0-9a-za-z_/\\w/ig;
	826	$_[0] =~ s/\[\\w\]/\\w/g;
	827	$_[0] =~ s/\[^\\w\]/\\W/g;
	828	$_[0] =~ s/\[0-9\]/\\d/g;
	829	$_[0] =~ s/\[^0-9\]/\\D/g;
	830	$_[0] =~ s/\\d\\d\*/\\d+/g;
	831	$_[0] =~ s/\\D\\D\*/\\D+/g;
	832	$_[0] =~ s/\\w\\w\*/\\w+/g;
	833	$_[0] =~ s/\\t\\t\*/\\t+/g;
	834	$_[0] =~ s/(\[.[^]]\])\1\/$1+/g;
	835	$_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
	836	}
	837
1aa91729	838	sub skip {
	839	local($level) = 0;
	840
	841	while(<BODY>) {
	842	/^#ifdef/ && $level++;
	843	/^#else/ && !$level && return;
	844	/^#endif/ && !$level-- && return;
	845	}
	846
	847	die "Unterminated `#ifdef' conditional\n";
	848	}
a687059c	849	!NO!SUBS!
4633a7c4	850
	851	close OUT or die "Can't close $file: $!";
	852	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	853	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1	854	chdir $origdir;