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

#!/usr/local/bin/perl

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

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

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