[perl5.git] / x2p / s2p.PL

#!/usr/local/bin/perl

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

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

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
chdir(dirname($0));
($file = basename($0)) =~ s/\.PL$//;
$file =~ s/\.pl$//
	if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"

open OUT,">$file" or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

print OUT <<"!GROK!THIS!";
$Config{'startperl'}
    eval 'exec perl -S \$0 "\$@"'
	if 0;
\$startperl = "$Config{startperl}";
!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<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt>

=head1 FILES

=head1 SEE ALSO

 perl	The perl compiler/interpreter
 
 a2p	awk to perl translator

=head1 DIAGNOSTICS

=head1 BUGS

=cut

$indent = 4;
$shiftwidth = 4;
$l = '{'; $r = '}';

while ($ARGV[0] =~ /^-/) {
    $_ = shift;
  last if /^--/;
    if (/^-D/) {
	$debug++;
	open(BODY,'>-');
	next;
    }
    if (/^-n/) {
	$assumen++;
	next;
    }
    if (/^-p/) {
	$assumep++;
	next;
    }
    die "I don't recognize this switch: $_\n";
}

unless ($debug) {
    open(BODY,">/tmp/sperl$$") ||
      &Die("Can't open temp file: $!\n");
}

if (!$assumen && !$assumep) {
    print BODY &q(<<'EOT');
:	while ($ARGV[0] =~ /^-/) {
:	    $_ = shift;
:	  last if /^--/;
:	    if (/^-n/) {
:		$nflag++;
:		next;
:	    }
:	    die "I don't recognize this switch: $_\\n";
:	}
:	
EOT
}

print BODY &q(<<'EOT');
:	#ifdef PRINTIT
:	#ifdef ASSUMEP
:	$printit++;
:	#else
:	$printit++ unless $nflag;
:	#endif
:	#endif
:	<><>
:	$\ = "\n";		# automatically add newline on print
:	<><>
:	#ifdef TOPLABEL
:	LINE:
:	while (chop($_ = <>)) {
:	#else
:	LINE:
:	while (<>) {
:	    chop;
:	#endif
EOT

LINE:
while (<>) {

    # Wipe out surrounding whitespace.

    s/[ \t]*(.*)\n$/$1/;

    # Perhaps it's a label/comment.

    if (/^:/) {
	s/^:[ \t]*//;
	$label = &make_label($_);
	if ($. == 1) {
	    $toplabel = $label;
	    if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
		$_ = <>;
		redo LINE; # Never referenced, so delete it if not a comment.
	    }
	}
	$_ = "$label:";
	if ($lastlinewaslabel++) {
	    $indent += 4;
	    print BODY &tab, ";\n";
	    $indent -= 4;
	}
	if ($indent >= 2) {
	    $indent -= 2;
	    $indmod = 2;
	}
	next;
    } else {
	$lastlinewaslabel = '';
    }

    # Look for one or two address clauses

    $addr1 = '';
    $addr2 = '';
    if (s/^([0-9]+)//) {
	$addr1 = "$1";
	$addr1 = "\$. == $addr1" unless /^,/;
    }
    elsif (s/^\$//) {
	$addr1 = 'eof()';
    }
    elsif (s|^/||) {
	$addr1 = &fetchpat('/');
    }
    if (s/^,//) {
	if (s/^([0-9]+)//) {
	    $addr2 = "$1";
	} elsif (s/^\$//) {
	    $addr2 = "eof()";
	} elsif (s|^/||) {
	    $addr2 = &fetchpat('/');
	} else {
	    &Die("Invalid second address at line $.\n");
	}
	if ($addr2 =~ /^\d+$/) {
	    $addr1 .= "..$addr2";
	}
	else {
	    $addr1 .= "...$addr2";
	}
    }

    # Now we check for metacommands {, }, and ! and worry
    # about indentation.

    s/^[ \t]+//;
    # a { to keep vi happy
    if ($_ eq '}') {
	$indent -= 4;
	next;
    }
    if (s/^!//) {
	$if = 'unless';
	$else = "$r else $l\n";
    } else {
	$if = 'if';
	$else = '';
    }
    if (s/^{//) {	# a } to keep vi happy
	$indmod = 4;
	$redo = $_;
	$_ = '';
	$rmaybe = '';
    } else {
	$rmaybe = "\n$r";
	if ($addr2 || $addr1) {
	    $space = ' ' x $shiftwidth;
	} else {
	    $space = '';
	}
	$_ = &transmogrify();
    }

    # See if we can optimize to modifier form.

    if ($addr1) {
	if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
	  $_ !~ / if / && $_ !~ / unless /) {
	    s/;$/ $if $addr1;/;
	    $_ = substr($_,$shiftwidth,1000);
	} else {
	    $_ = "$if ($addr1) $l\n$change$_$rmaybe";
	}
	$change = '';
	next LINE;
    }
} continue {
    @lines = split(/\n/,$_);
    for (@lines) {
	unless (s/^ *<<--//) {
	    print BODY &tab;
	}
	print BODY $_, "\n";
    }
    $indent += $indmod;
    $indmod = 0;
    if ($redo) {
	$_ = $redo;
	$redo = '';
	redo LINE;
    }
}
if ($lastlinewaslabel++) {
    $indent += 4;
    print BODY &tab, ";\n";
    $indent -= 4;
}

if ($appendseen || $tseen || !$assumen) {
    $printit++ if $dseen || (!$assumen && !$assumep);
    print BODY &q(<<'EOT');
:	#ifdef SAWNEXT
:	}
:	continue {
:	#endif
:	#ifdef PRINTIT
:	#ifdef DSEEN
:	#ifdef ASSUMEP
:	    print if $printit++;
:	#else
:	    if ($printit)
:		{ print; }
:	    else
:		{ $printit++ unless $nflag; }
:	#endif
:	#else
:	    print if $printit;
:	#endif
:	#else
:	    print;
:	#endif
:	#ifdef TSEEN
:	    $tflag = 0;
:	#endif
:	#ifdef APPENDSEEN
:	    if ($atext) { chop $atext; print $atext; $atext = ''; }
:	#endif
EOT

print BODY &q(<<'EOT');
:	}
EOT
}

close BODY;

unless ($debug) {
    open(HEAD,">/tmp/sperl2$$.c")
      || &Die("Can't open temp file 2: $!\n");
    print HEAD "#define PRINTIT\n"	if $printit;
    print HEAD "#define APPENDSEEN\n"	if $appendseen;
    print HEAD "#define TSEEN\n"	if $tseen;
    print HEAD "#define DSEEN\n"	if $dseen;
    print HEAD "#define ASSUMEN\n"	if $assumen;
    print HEAD "#define ASSUMEP\n"	if $assumep;
    print HEAD "#define TOPLABEL\n"	if $toplabel;
    print HEAD "#define SAWNEXT\n"	if $sawnext;
    if ($opens) {print HEAD "$opens\n";}
    open(BODY,"/tmp/sperl$$")
      || &Die("Can't reopen temp file: $!\n");
    while (<BODY>) {
	print HEAD $_;
    }
    close HEAD;

    print &q(<<"EOT");
:	$startperl
:	eval 'exec perl -S \$0 \${1+"\$@"}'
:		if \$running_under_some_shell;
:	
EOT
    open(BODY,"cc -E /tmp/sperl2$$.c |") ||
	&Die("Can't reopen temp file: $!\n");
    while (<BODY>) {
	/^# [0-9]/ && next;
	/^[ \t]*$/ && next;
	s/^<><>//;
	print;
    }
}

&Cleanup;
exit;

sub Cleanup {
    chdir "/tmp";
    unlink "sperl$$", "sperl2$$", "sperl2$$.c";
}
sub Die {
    &Cleanup;
    die $_[0];
}
sub tab {
    "\t" x ($indent / 8) . ' ' x ($indent % 8);
}
sub make_filehandle {
    local($_) = $_[0];
    local($fname) = $_;
    if (!$seen{$fname}) {
	$_ = "FH_" . $_ if /^\d/;
	s/[^a-zA-Z0-9]/_/g;
	s/^_*//;
	$_ = "\U$_";
	if ($fhseen{$_}) {
	    for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
	    $_ .= $tmp;
	}
	$fhseen{$_} = 1;
	$opens .= &q(<<"EOT");
:	open($_, '>$fname') || die "Can't create $fname: \$!";
EOT
	$seen{$fname} = $_;
    }
    $seen{$fname};
}

sub make_label {
    local($label) = @_;
    $label =~ s/[^a-zA-Z0-9]/_/g;
    if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
    $label = substr($label,0,8);

    # Could be a reserved word, so capitalize it.
    substr($label,0,1) =~ y/a-z/A-Z/
      if $label =~ /^[a-z]/;

    $label;
}

sub transmogrify {
    {	# case
	if (/^d/) {
	    $dseen++;
	    chop($_ = &q(<<'EOT'));
:	<<--#ifdef PRINTIT
:	$printit = 0;
:	<<--#endif
:	next LINE;
EOT
	    $sawnext++;
	    next;
	}

	if (/^n/) {
	    chop($_ = &q(<<'EOT'));
:	<<--#ifdef PRINTIT
:	<<--#ifdef DSEEN
:	<<--#ifdef ASSUMEP
:	print if $printit++;
:	<<--#else
:	if ($printit)
:	    { print; }
:	else
:	    { $printit++ unless $nflag; }
:	<<--#endif
:	<<--#else
:	print if $printit;
:	<<--#endif
:	<<--#else
:	print;
:	<<--#endif
:	<<--#ifdef APPENDSEEN
:	if ($atext) {chop $atext; print $atext; $atext = '';}
:	<<--#endif
:	$_ = <>;
:	chop;
:	<<--#ifdef TSEEN
:	$tflag = 0;
:	<<--#endif
EOT
	    next;
	}

	if (/^a/) {
	    $appendseen++;
	    $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
	    $lastline = 0;
	    while (<>) {
		s/^[ \t]*//;
		s/^[\\]//;
		unless (s|\\$||) { $lastline = 1;}
		s/^([ \t]*\n)/<><>$1/;
		$command .= $_;
		$command .= '<<--';
		last if $lastline;
	    }
	    $_ = $command . "End_Of_Text";
	    last;
	}

	if (/^[ic]/) {
	    if (/^c/) { $change = 1; }
	    $addr1 = 1 if $addr1 eq '';
	    $addr1 = '$iter = (' . $addr1 . ')';
	    $command = $space .
	      "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
	    $lastline = 0;
	    while (<>) {
		s/^[ \t]*//;
		s/^[\\]//;
		unless (s/\\$//) { $lastline = 1;}
		s/'/\\'/g;
		s/^([ \t]*\n)/<><>$1/;
		$command .= $_;
		$command .= '<<--';
		last if $lastline;
	    }
	    $_ = $command . "End_Of_Text";
	    if ($change) {
		$dseen++;
		$change = "$_\n";
		chop($_ = &q(<<"EOT"));
:	<<--#ifdef PRINTIT
:	$space\$printit = 0;
:	<<--#endif
:	${space}next LINE;
EOT
		$sawnext++;
	    }
	    last;
	}

	if (/^s/) {
	    $delim = substr($_,1,1);
	    $len = length($_);
	    $repl = $end = 0;
	    $inbracket = 0;
	    for ($i = 2; $i < $len; $i++) {
		$c = substr($_,$i,1);
		if ($c eq $delim) {
		    if ($inbracket) {
			substr($_, $i, 0) = '\\';
			$i++;
			$len++;
		    }
		    else {
			if ($repl) {
			    $end = $i;
			    last;
			} else {
			    $repl = $i;
			}
		    }
		}
		elsif ($c eq '\\') {
		    $i++;
		    if ($i >= $len) {
			$_ .= 'n';
			$_ .= <>;
			$len = length($_);
			$_ = substr($_,0,--$len);
		    }
		    elsif (substr($_,$i,1) =~ /^[n]$/) {
			;
		    }
		    elsif (!$repl &&
		      substr($_,$i,1) =~ /^[(){}\w]$/) {
			$i--;
			$len--;
			substr($_, $i, 1) = '';
		    }
		    elsif (!$repl &&
		      substr($_,$i,1) =~ /^[<>]$/) {
			substr($_,$i,1) = 'b';
		    }
		    elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
			substr($_,$i-1,1) = '$';
		    }
		}
		elsif ($c eq '&' && $repl) {
		    substr($_, $i, 0) = '$';
		    $i++;
		    $len++;
		}
		elsif ($c eq '$' && $repl) {
		    substr($_, $i, 0) = '\\';
		    $i++;
		    $len++;
		}
		elsif ($c eq '[' && !$repl) {
		    $i++ if substr($_,$i,1) eq '^';
		    $i++ if substr($_,$i,1) eq ']';
		    $inbracket = 1;
		}
		elsif ($c eq ']') {
		    $inbracket = 0;
		}
		elsif ($c eq "\t") {
		    substr($_, $i, 1) = '\\t';
		    $i++;
		    $len++;
		}
		elsif (!$repl && index("()+",$c) >= 0) {
		    substr($_, $i, 0) = '\\';
		    $i++;
		    $len++;
		}
	    }
	    &Die("Malformed substitution at line $.\n")
	      unless $end;
	    $pat = substr($_, 0, $repl + 1);
	    $repl = substr($_, $repl+1, $end-$repl-1);
	    $end = substr($_, $end + 1, 1000);
	    &simplify($pat);
	    $dol = '$';
	    $subst = "$pat$repl$delim";
	    $cmd = '';
	    while ($end) {
		if ($end =~ s/^g//) {
		    $subst .= 'g';
		    next;
		}
		if ($end =~ s/^p//) {
		    $cmd .= ' && (print)';
		    next;
		}
		if ($end =~ s/^w[ \t]*//) {
		    $fh = &make_filehandle($end);
		    $cmd .= " && (print $fh \$_)";
		    $end = '';
		    next;
		}
		&Die("Unrecognized substitution command".
		  "($end) at line $.\n");
	    }
	    chop ($_ = &q(<<"EOT"));
:	<<--#ifdef TSEEN
:	$subst && \$tflag++$cmd;
:	<<--#else
:	$subst$cmd;
:	<<--#endif
EOT
	    next;
	}

	if (/^p/) {
	    $_ = 'print;';
	    next;
	}

	if (/^w/) {
	    s/^w[ \t]*//;
	    $fh = &make_filehandle($_);
	    $_ = "print $fh \$_;";
	    next;
	}

	if (/^r/) {
	    $appendseen++;
	    s/^r[ \t]*//;
	    $file = $_;
	    $_ = "\$atext .= `cat $file 2>/dev/null`;";
	    next;
	}

	if (/^P/) {
	    $_ = 'print $1 if /^(.*)/;';
	    next;
	}

	if (/^D/) {
	    chop($_ = &q(<<'EOT'));
:	s/^.*\n?//;
:	redo LINE if $_;
:	next LINE;
EOT
	    $sawnext++;
	    next;
	}

	if (/^N/) {
	    chop($_ = &q(<<'EOT'));
:	$_ .= "\n";
:	$len1 = length;
:	$_ .= <>;
:	chop if $len1 < length;
:	<<--#ifdef TSEEN
:	$tflag = 0;
:	<<--#endif
EOT
	    next;
	}

	if (/^h/) {
	    $_ = '$hold = $_;';
	    next;
	}

	if (/^H/) {
	    $_ = '$hold .= "\n"; $hold .= $_;';
	    next;
	}

	if (/^g/) {
	    $_ = '$_ = $hold;';
	    next;
	}

	if (/^G/) {
	    $_ = '$_ .= "\n"; $_ .= $hold;';
	    next;
	}

	if (/^x/) {
	    $_ = '($_, $hold) = ($hold, $_);';
	    next;
	}

	if (/^b$/) {
	    $_ = 'next LINE;';
	    $sawnext++;
	    next;
	}

	if (/^b/) {
	    s/^b[ \t]*//;
	    $lab = &make_label($_);
	    if ($lab eq $toplabel) {
		$_ = 'redo LINE;';
	    } else {
		$_ = "goto $lab;";
	    }
	    next;
	}

	if (/^t$/) {
	    $_ = 'next LINE if $tflag;';
	    $sawnext++;
	    $tseen++;
	    next;
	}

	if (/^t/) {
	    s/^t[ \t]*//;
	    $lab = &make_label($_);
	    $_ = q/if ($tflag) {$tflag = 0; /;
	    if ($lab eq $toplabel) {
		$_ .= 'redo LINE;}';
	    } else {
		$_ .= "goto $lab;}";
	    }
	    $tseen++;
	    next;
	}

	if (/^y/) {
	    s/abcdefghijklmnopqrstuvwxyz/a-z/g;
	    s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
	    s/abcdef/a-f/g;
	    s/ABCDEF/A-F/g;
	    s/0123456789/0-9/g;
	    s/01234567/0-7/g;
	    $_ .= ';';
	}

	if (/^=/) {
	    $_ = 'print $.;';
	    next;
	}

	if (/^q/) {
	    chop($_ = &q(<<'EOT'));
:	close(ARGV);
:	@ARGV = ();
:	next LINE;
EOT
	    $sawnext++;
	    next;
	}
    } continue {
	if ($space) {
	    s/^/$space/;
	    s/(\n)(.)/$1$space$2/g;
	}
	last;
    }
    $_;
}

sub fetchpat {
    local($outer) = @_;
    local($addr) = $outer;
    local($inbracket);
    local($prefix,$delim,$ch);

    # Process pattern one potential delimiter at a time.

    DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
	$prefix = $1;
	$delim = $2;
	if ($delim eq '\\') {
	    s/(.)//;
	    $ch = $1;
	    $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
	    $ch = 'b' if $ch =~ /^[<>]$/;
	    $delim .= $ch;
	}
	elsif ($delim eq '[') {
	    $inbracket = 1;
	    s/^\^// && ($delim .= '^');
	    s/^]// && ($delim .= ']');
	}
	elsif ($delim eq ']') {
	    $inbracket = 0;
	}
	elsif ($inbracket || $delim ne $outer) {
	    $delim = '\\' . $delim;
	}
	$addr .= $prefix;
	$addr .= $delim;
	if ($delim eq $outer && !$inbracket) {
	    last DELIM;
	}
    }
    $addr =~ s/\t/\\t/g;
    &simplify($addr);
    $addr;
}

sub q {
    local($string) = @_;
    local($*) = 1;
    $string =~ s/^:\t?//g;
    $string;
}

sub simplify {
    $_[0] =~ s/_a-za-z0-9/\\w/ig;
    $_[0] =~ s/a-z_a-z0-9/\\w/ig;
    $_[0] =~ s/a-za-z_0-9/\\w/ig;
    $_[0] =~ s/a-za-z0-9_/\\w/ig;
    $_[0] =~ s/_0-9a-za-z/\\w/ig;
    $_[0] =~ s/0-9_a-za-z/\\w/ig;
    $_[0] =~ s/0-9a-z_a-z/\\w/ig;
    $_[0] =~ s/0-9a-za-z_/\\w/ig;
    $_[0] =~ s/\[\\w\]/\\w/g;
    $_[0] =~ s/\[^\\w\]/\\W/g;
    $_[0] =~ s/\[0-9\]/\\d/g;
    $_[0] =~ s/\[^0-9\]/\\D/g;
    $_[0] =~ s/\\d\\d\*/\\d+/g;
    $_[0] =~ s/\\D\\D\*/\\D+/g;
    $_[0] =~ s/\\w\\w\*/\\w+/g;
    $_[0] =~ s/\\t\\t\*/\\t+/g;
    $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
    $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
}

!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
Commit	Line	Data
4633a7c4 LW	1	#!/usr/local/bin/perl
	2
	3	use Config;
	4	use File::Basename qw(&basename &dirname);
	5
	6	# List explicitly here the variables you want Configure to
	7	# generate. Metaconfig only looks for shell variables, so you
	8	# have to mention them as if they were shell variables, not
	9	# %Config entries. Thus you write
	10	# $startperl
	11	# to ensure Configure will look for $Config{startperl}.
	12
	13	# This forces PL files to create target in same directory as PL file.
	14	# This is so that make depend always knows where to find PL derivatives.
	15	chdir(dirname($0));
	16	($file = basename($0)) =~ s/\.PL$//;
	17	$file =~ s/\.pl$//
f360dba1	18	if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
4633a7c4 LW	19
	20	open OUT,">$file" or die "Can't create $file: $!";
	21
	22	print "Extracting $file (with variable substitutions)\n";
	23
	24	# In this section, perl variables will be expanded during extraction.
	25	# You can use $Config{...} to use Configure variables.
	26
	27	print OUT <<"!GROK!THIS!";
	28	$Config{'startperl'}
	29	eval 'exec perl -S \$0 "\$@"'
	30	if 0;
f70b6ff5	31	\$startperl = "$Config{startperl}";
a687059c LW	32	!GROK!THIS!
a687059c LW	33
4633a7c4 LW	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 JM	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
	98	Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt>
	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 LW	114	$indent = 4;
	115	$shiftwidth = 4;
	116	$l = '{'; $r = '}';
8d063cd8	117
0a12ae7d	118	while ($ARGV[0] =~ /^-/) {
8d063cd8 LW	119	$_ = shift;
	120	last if /^--/;
	121	if (/^-D/) {
	122	$debug++;
0a12ae7d	123	open(BODY,'>-');
8d063cd8 LW	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 LW	135	}
	136
	137	unless ($debug) {
0a12ae7d LW	138	open(BODY,">/tmp/sperl$$") \|\|
0a12ae7d LW	139	&Die("Can't open temp file: $!\n");
8d063cd8 LW	140	}
	141
	142	if (!$assumen && !$assumep) {
9ef589d8 LW	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 LW	155	}
8d063cd8 LW	156
9ef589d8 LW	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 LW	176	EOT
0a12ae7d LW	177
9ef589d8 LW	178	LINE:
9ef589d8 LW	179	while (<>) {
0a12ae7d LW	180
0a12ae7d LW	181	# Wipe out surrounding whitespace.
8d063cd8	182
8d063cd8	183	s/[ \t](.)\n$/$1/;
0a12ae7d LW	184
	185	# Perhaps it's a label/comment.
	186
8d063cd8 LW	187	if (/^:/) {
8d063cd8 LW	188	s/^:[ \t]*//;
0a12ae7d	189	$label = &make_label($_);
8d063cd8 LW	190	if ($. == 1) {
8d063cd8 LW	191	$toplabel = $label;
9ef589d8 LW	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 LW	196	}
8d063cd8 LW	197	$_ = "$label:";
ffed7fef LW	198	if ($lastlinewaslabel++) {
ffed7fef LW	199	$indent += 4;
0a12ae7d	200	print BODY &tab, ";\n";
ffed7fef LW	201	$indent -= 4;
ffed7fef LW	202	}
8d063cd8 LW	203	if ($indent >= 2) {
	204	$indent -= 2;
	205	$indmod = 2;
	206	}
	207	next;
	208	} else {
	209	$lastlinewaslabel = '';
	210	}
0a12ae7d LW	211
	212	# Look for one or two address clauses
	213
8d063cd8 LW	214	$addr1 = '';
	215	$addr2 = '';
	216	if (s/^([0-9]+)//) {
	217	$addr1 = "$1";
9ef589d8	218	$addr1 = "\$. == $addr1" unless /^,/;
8d063cd8 LW	219	}
	220	elsif (s/^\$//) {
	221	$addr1 = 'eof()';
	222	}
	223	elsif (s\|^/\|\|) {
0a12ae7d	224	$addr1 = &fetchpat('/');
8d063cd8 LW	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 LW	236	if ($addr2 =~ /^\d+$/) {
	237	$addr1 .= "..$addr2";
	238	}
	239	else {
	240	$addr1 .= "...$addr2";
	241	}
8d063cd8	242	}
0a12ae7d LW	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 LW	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 LW	269	} else {
	270	$space = '';
	271	}
0a12ae7d	272	$_ = &transmogrify();
8d063cd8 LW	273	}
8d063cd8 LW	274
0a12ae7d LW	275	# See if we can optimize to modifier form.
0a12ae7d LW	276
8d063cd8 LW	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 LW	284	}
8d063cd8 LW	285	$change = '';
0a12ae7d	286	next LINE;
8d063cd8 LW	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 LW	295	}
	296	$indent += $indmod;
	297	$indmod = 0;
	298	if ($redo) {
	299	$_ = $redo;
	300	$redo = '';
0a12ae7d	301	redo LINE;
8d063cd8 LW	302	}
8d063cd8 LW	303	}
ffed7fef LW	304	if ($lastlinewaslabel++) {
ffed7fef LW	305	$indent += 4;
0a12ae7d	306	print BODY &tab, ";\n";
ffed7fef LW	307	$indent -= 4;
ffed7fef LW	308	}
8d063cd8	309
8d063cd8 LW	310	if ($appendseen \|\| $tseen \|\| !$assumen) {
8d063cd8 LW	311	$printit++ if $dseen \|\| (!$assumen && !$assumep);
9ef589d8 LW	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 LW	344	}
8d063cd8 LW	345
0a12ae7d	346	close BODY;
8d063cd8 LW	347
8d063cd8 LW	348	unless ($debug) {
0a12ae7d LW	349	open(HEAD,">/tmp/sperl2$$.c")
0a12ae7d LW	350	\|\| &Die("Can't open temp file 2: $!\n");
9ef589d8 LW	351	print HEAD "#define PRINTIT\n" if $printit;
	352	print HEAD "#define APPENDSEEN\n" if $appendseen;
	353	print HEAD "#define TSEEN\n" if $tseen;
	354	print HEAD "#define DSEEN\n" if $dseen;
	355	print HEAD "#define ASSUMEN\n" if $assumen;
	356	print HEAD "#define ASSUMEP\n" if $assumep;
	357	print HEAD "#define TOPLABEL\n" if $toplabel;
	358	print HEAD "#define SAWNEXT\n" if $sawnext;
0a12ae7d LW	359	if ($opens) {print HEAD "$opens\n";}
	360	open(BODY,"/tmp/sperl$$")
	361	\|\| &Die("Can't reopen temp file: $!\n");
	362	while (<BODY>) {
	363	print HEAD $_;
8d063cd8	364	}
0a12ae7d	365	close HEAD;
8d063cd8	366
9ef589d8	367	print &q(<<"EOT");
4633a7c4 LW	368	: $startperl
4633a7c4 LW	369	: eval 'exec perl -S \$0 \${1+"\$@"}'
9ef589d8 LW	370	: if \$running_under_some_shell;
9ef589d8 LW	371	:
0a12ae7d LW	372	EOT
	373	open(BODY,"cc -E /tmp/sperl2$$.c \|") \|\|
	374	&Die("Can't reopen temp file: $!\n");
	375	while (<BODY>) {
8d063cd8 LW	376	/^# [0-9]/ && next;
	377	/^[ \t]*$/ && next;
	378	s/^<><>//;
	379	print;
	380	}
	381	}
	382
0a12ae7d LW	383	&Cleanup;
0a12ae7d LW	384	exit;
8d063cd8	385
0a12ae7d LW	386	sub Cleanup {
	387	chdir "/tmp";
	388	unlink "sperl$$", "sperl2$$", "sperl2$$.c";
	389	}
8d063cd8	390	sub Die {
0a12ae7d	391	&Cleanup;
8d063cd8 LW	392	die $_[0];
8d063cd8 LW	393	}
0a12ae7d LW	394	sub tab {
	395	"\t" x ($indent / 8) . ' ' x ($indent % 8);
	396	}
8d063cd8	397	sub make_filehandle {
0a12ae7d LW	398	local($_) = $_[0];
0a12ae7d LW	399	local($fname) = $_;
9ef589d8 LW	400	if (!$seen{$fname}) {
	401	$_ = "FH_" . $_ if /^\d/;
	402	s/[^a-zA-Z0-9]/_/g;
	403	s/^_*//;
	404	$_ = "\U$_";
	405	if ($fhseen{$_}) {
	406	for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
	407	$_ .= $tmp;
	408	}
	409	$fhseen{$_} = 1;
	410	$opens .= &q(<<"EOT");
	411	: open($_, '>$fname') \|\| die "Can't create $fname: \$!";
0a12ae7d	412	EOT
9ef589d8	413	$seen{$fname} = $_;
8d063cd8	414	}
9ef589d8	415	$seen{$fname};
8d063cd8 LW	416	}
	417
	418	sub make_label {
0a12ae7d	419	local($label) = @_;
8d063cd8 LW	420	$label =~ s/[^a-zA-Z0-9]/_/g;
	421	if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
	422	$label = substr($label,0,8);
0a12ae7d LW	423
	424	# Could be a reserved word, so capitalize it.
	425	substr($label,0,1) =~ y/a-z/A-Z/
	426	if $label =~ /^[a-z]/;
	427
8d063cd8 LW	428	$label;
	429	}
	430
	431	sub transmogrify {
	432	{ # case
	433	if (/^d/) {
	434	$dseen++;
9ef589d8 LW	435	chop($_ = &q(<<'EOT'));
	436	: <<--#ifdef PRINTIT
	437	: $printit = 0;
	438	: <<--#endif
	439	: next LINE;
0a12ae7d	440	EOT
9ef589d8	441	$sawnext++;
8d063cd8 LW	442	next;
	443	}
	444
	445	if (/^n/) {
9ef589d8 LW	446	chop($_ = &q(<<'EOT'));
	447	: <<--#ifdef PRINTIT
	448	: <<--#ifdef DSEEN
	449	: <<--#ifdef ASSUMEP
	450	: print if $printit++;
	451	: <<--#else
	452	: if ($printit)
	453	: { print; }
	454	: else
	455	: { $printit++ unless $nflag; }
	456	: <<--#endif
	457	: <<--#else
	458	: print if $printit;
	459	: <<--#endif
	460	: <<--#else
	461	: print;
	462	: <<--#endif
	463	: <<--#ifdef APPENDSEEN
	464	: if ($atext) {chop $atext; print $atext; $atext = '';}
	465	: <<--#endif
	466	: $_ = <>;
	467	: chop;
	468	: <<--#ifdef TSEEN
	469	: $tflag = 0;
	470	: <<--#endif
0a12ae7d	471	EOT
8d063cd8 LW	472	next;
	473	}
	474
	475	if (/^a/) {
	476	$appendseen++;
9ef589d8	477	$command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
8d063cd8 LW	478	$lastline = 0;
	479	while (<>) {
	480	s/^[ \t]*//;
	481	s/^[\\]//;
	482	unless (s\|\\$\|\|) { $lastline = 1;}
8d063cd8 LW	483	s/^([ \t]*\n)/<><>$1/;
	484	$command .= $_;
	485	$command .= '<<--';
	486	last if $lastline;
	487	}
9ef589d8	488	$_ = $command . "End_Of_Text";
8d063cd8 LW	489	last;
	490	}
	491
	492	if (/^[ic]/) {
	493	if (/^c/) { $change = 1; }
9ef589d8	494	$addr1 = 1 if $addr1 eq '';
8d063cd8	495	$addr1 = '$iter = (' . $addr1 . ')';
9ef589d8 LW	496	$command = $space .
9ef589d8 LW	497	" if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
8d063cd8 LW	498	$lastline = 0;
	499	while (<>) {
	500	s/^[ \t]*//;
	501	s/^[\\]//;
	502	unless (s/\\$//) { $lastline = 1;}
	503	s/'/\\'/g;
	504	s/^([ \t]*\n)/<><>$1/;
	505	$command .= $_;
	506	$command .= '<<--';
	507	last if $lastline;
	508	}
9ef589d8	509	$_ = $command . "End_Of_Text";
8d063cd8 LW	510	if ($change) {
	511	$dseen++;
	512	$change = "$_\n";
9ef589d8 LW	513	chop($_ = &q(<<"EOT"));
	514	: <<--#ifdef PRINTIT
	515	: $space\$printit = 0;
	516	: <<--#endif
	517	: ${space}next LINE;
0a12ae7d	518	EOT
9ef589d8	519	$sawnext++;
8d063cd8 LW	520	}
	521	last;
	522	}
	523
	524	if (/^s/) {
	525	$delim = substr($_,1,1);
	526	$len = length($_);
	527	$repl = $end = 0;
a687059c	528	$inbracket = 0;
8d063cd8 LW	529	for ($i = 2; $i < $len; $i++) {
8d063cd8 LW	530	$c = substr($_,$i,1);
a687059c LW	531	if ($c eq $delim) {
a687059c LW	532	if ($inbracket) {
0a12ae7d	533	substr($_, $i, 0) = '\\';
a687059c LW	534	$i++;
	535	$len++;
	536	}
	537	else {
	538	if ($repl) {
	539	$end = $i;
	540	last;
	541	} else {
	542	$repl = $i;
	543	}
	544	}
	545	}
	546	elsif ($c eq '\\') {
8d063cd8 LW	547	$i++;
	548	if ($i >= $len) {
	549	$_ .= 'n';
	550	$_ .= <>;
	551	$len = length($_);
	552	$_ = substr($_,0,--$len);
	553	}
00bf170e LW	554	elsif (substr($_,$i,1) =~ /^[n]$/) {
	555	;
	556	}
0a12ae7d LW	557	elsif (!$repl &&
0a12ae7d LW	558	substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8 LW	559	$i--;
8d063cd8 LW	560	$len--;
0a12ae7d	561	substr($_, $i, 1) = '';
8d063cd8	562	}
0a12ae7d LW	563	elsif (!$repl &&
0a12ae7d LW	564	substr($_,$i,1) =~ /^[<>]$/) {
9f68db38 LW	565	substr($_,$i,1) = 'b';
9f68db38 LW	566	}
2b69d0c2 LW	567	elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
	568	substr($_,$i-1,1) = '$';
	569	}
	570	}
	571	elsif ($c eq '&' && $repl) {
	572	substr($_, $i, 0) = '$';
	573	$i++;
	574	$len++;
	575	}
	576	elsif ($c eq '$' && $repl) {
	577	substr($_, $i, 0) = '\\';
	578	$i++;
	579	$len++;
8d063cd8	580	}
a687059c LW	581	elsif ($c eq '[' && !$repl) {
	582	$i++ if substr($_,$i,1) eq '^';
	583	$i++ if substr($_,$i,1) eq ']';
	584	$inbracket = 1;
8d063cd8	585	}
a687059c LW	586	elsif ($c eq ']') {
	587	$inbracket = 0;
	588	}
9ef589d8 LW	589	elsif ($c eq "\t") {
	590	substr($_, $i, 1) = '\\t';
	591	$i++;
	592	$len++;
	593	}
ae986130	594	elsif (!$repl && index("()+",$c) >= 0) {
0a12ae7d	595	substr($_, $i, 0) = '\\';
8d063cd8 LW	596	$i++;
	597	$len++;
	598	}
	599	}
0a12ae7d LW	600	&Die("Malformed substitution at line $.\n")
0a12ae7d LW	601	unless $end;
8d063cd8	602	$pat = substr($_, 0, $repl + 1);
0a12ae7d	603	$repl = substr($_, $repl+1, $end-$repl-1);
8d063cd8	604	$end = substr($_, $end + 1, 1000);
9ef589d8	605	&simplify($pat);
8d063cd8	606	$dol = '$';
8d063cd8 LW	607	$subst = "$pat$repl$delim";
	608	$cmd = '';
	609	while ($end) {
0a12ae7d LW	610	if ($end =~ s/^g//) {
	611	$subst .= 'g';
	612	next;
	613	}
	614	if ($end =~ s/^p//) {
	615	$cmd .= ' && (print)';
	616	next;
	617	}
8d063cd8	618	if ($end =~ s/^w[ \t]*//) {
0a12ae7d	619	$fh = &make_filehandle($end);
8d063cd8 LW	620	$cmd .= " && (print $fh \$_)";
	621	$end = '';
	622	next;
	623	}
0a12ae7d LW	624	&Die("Unrecognized substitution command".
0a12ae7d LW	625	"($end) at line $.\n");
8d063cd8	626	}
9ef589d8 LW	627	chop ($_ = &q(<<"EOT"));
	628	: <<--#ifdef TSEEN
	629	: $subst && \$tflag++$cmd;
	630	: <<--#else
	631	: $subst$cmd;
	632	: <<--#endif
0a12ae7d	633	EOT
8d063cd8 LW	634	next;
	635	}
	636
	637	if (/^p/) {
	638	$_ = 'print;';
	639	next;
	640	}
	641
	642	if (/^w/) {
	643	s/^w[ \t]*//;
0a12ae7d	644	$fh = &make_filehandle($_);
8d063cd8 LW	645	$_ = "print $fh \$_;";
	646	next;
	647	}
	648
	649	if (/^r/) {
	650	$appendseen++;
	651	s/^r[ \t]*//;
	652	$file = $_;
	653	$_ = "\$atext .= `cat $file 2>/dev/null`;";
	654	next;
	655	}
	656
	657	if (/^P/) {
9ef589d8	658	$_ = 'print $1 if /^(.*)/;';
8d063cd8 LW	659	next;
	660	}
	661
	662	if (/^D/) {
9ef589d8 LW	663	chop($_ = &q(<<'EOT'));
	664	: s/^.*\n?//;
	665	: redo LINE if $_;
	666	: next LINE;
0a12ae7d	667	EOT
9ef589d8	668	$sawnext++;
8d063cd8 LW	669	next;
	670	}
	671
	672	if (/^N/) {
9ef589d8 LW	673	chop($_ = &q(<<'EOT'));
	674	: $_ .= "\n";
	675	: $len1 = length;
	676	: $_ .= <>;
	677	: chop if $len1 < length;
	678	: <<--#ifdef TSEEN
	679	: $tflag = 0;
	680	: <<--#endif
0a12ae7d	681	EOT
8d063cd8 LW	682	next;
	683	}
	684
	685	if (/^h/) {
	686	$_ = '$hold = $_;';
	687	next;
	688	}
	689
	690	if (/^H/) {
9ef589d8	691	$_ = '$hold .= "\n"; $hold .= $_;';
8d063cd8 LW	692	next;
	693	}
	694
	695	if (/^g/) {
	696	$_ = '$_ = $hold;';
	697	next;
	698	}
	699
	700	if (/^G/) {
9ef589d8	701	$_ = '$_ .= "\n"; $_ .= $hold;';
8d063cd8 LW	702	next;
	703	}
	704
	705	if (/^x/) {
	706	$_ = '($_, $hold) = ($hold, $_);';
	707	next;
	708	}
	709
	710	if (/^b$/) {
0a12ae7d	711	$_ = 'next LINE;';
9ef589d8	712	$sawnext++;
8d063cd8 LW	713	next;
	714	}
	715
	716	if (/^b/) {
	717	s/^b[ \t]*//;
0a12ae7d	718	$lab = &make_label($_);
8d063cd8	719	if ($lab eq $toplabel) {
0a12ae7d	720	$_ = 'redo LINE;';
8d063cd8 LW	721	} else {
	722	$_ = "goto $lab;";
	723	}
	724	next;
	725	}
	726
	727	if (/^t$/) {
0a12ae7d	728	$_ = 'next LINE if $tflag;';
9ef589d8	729	$sawnext++;
8d063cd8 LW	730	$tseen++;
	731	next;
	732	}
	733
	734	if (/^t/) {
	735	s/^t[ \t]*//;
0a12ae7d	736	$lab = &make_label($_);
9ef589d8	737	$_ = q/if ($tflag) {$tflag = 0; /;
8d063cd8	738	if ($lab eq $toplabel) {
0a12ae7d	739	$_ .= 'redo LINE;}';
8d063cd8	740	} else {
0a12ae7d	741	$_ .= "goto $lab;}";
8d063cd8 LW	742	}
	743	$tseen++;
	744	next;
	745	}
	746
9ef589d8 LW	747	if (/^y/) {
	748	s/abcdefghijklmnopqrstuvwxyz/a-z/g;
	749	s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
	750	s/abcdef/a-f/g;
	751	s/ABCDEF/A-F/g;
	752	s/0123456789/0-9/g;
	753	s/01234567/0-7/g;
	754	$_ .= ';';
	755	}
	756
8d063cd8	757	if (/^=/) {
9ef589d8	758	$_ = 'print $.;';
8d063cd8 LW	759	next;
	760	}
	761
	762	if (/^q/) {
9ef589d8 LW	763	chop($_ = &q(<<'EOT'));
	764	: close(ARGV);
	765	: @ARGV = ();
	766	: next LINE;
0a12ae7d	767	EOT
9ef589d8	768	$sawnext++;
8d063cd8 LW	769	next;
	770	}
	771	} continue {
	772	if ($space) {
	773	s/^/$space/;
	774	s/(\n)(.)/$1$space$2/g;
	775	}
	776	last;
	777	}
	778	$_;
	779	}
	780
a687059c LW	781	sub fetchpat {
	782	local($outer) = @_;
	783	local($addr) = $outer;
	784	local($inbracket);
	785	local($prefix,$delim,$ch);
	786
0a12ae7d LW	787	# Process pattern one potential delimiter at a time.
	788
	789	DELIM: while (s#^([^\]+(\|)[\\/]*)([]+(\|)[\\/])##) {
a687059c LW	790	$prefix = $1;
a687059c LW	791	$delim = $2;
a687059c LW	792	if ($delim eq '\\') {
	793	s/(.)//;
	794	$ch = $1;
00bf170e	795	$delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
9f68db38 LW	796	$ch = 'b' if $ch =~ /^[<>]$/;
9f68db38 LW	797	$delim .= $ch;
a687059c LW	798	}
	799	elsif ($delim eq '[') {
	800	$inbracket = 1;
	801	s/^\^// && ($delim .= '^');
	802	s/^]// && ($delim .= ']');
a687059c LW	803	}
	804	elsif ($delim eq ']') {
	805	$inbracket = 0;
	806	}
	807	elsif ($inbracket \|\| $delim ne $outer) {
a687059c LW	808	$delim = '\\' . $delim;
	809	}
	810	$addr .= $prefix;
	811	$addr .= $delim;
	812	if ($delim eq $outer && !$inbracket) {
0a12ae7d	813	last DELIM;
a687059c LW	814	}
a687059c LW	815	}
9ef589d8 LW	816	$addr =~ s/\t/\\t/g;
9ef589d8 LW	817	&simplify($addr);
a687059c LW	818	$addr;
	819	}
	820
9ef589d8 LW	821	sub q {
	822	local($string) = @_;
	823	local($*) = 1;
	824	$string =~ s/^:\t?//g;
	825	$string;
	826	}
	827
	828	sub simplify {
	829	$_[0] =~ s/_a-za-z0-9/\\w/ig;
	830	$_[0] =~ s/a-z_a-z0-9/\\w/ig;
	831	$_[0] =~ s/a-za-z_0-9/\\w/ig;
	832	$_[0] =~ s/a-za-z0-9_/\\w/ig;
	833	$_[0] =~ s/_0-9a-za-z/\\w/ig;
	834	$_[0] =~ s/0-9_a-za-z/\\w/ig;
	835	$_[0] =~ s/0-9a-z_a-z/\\w/ig;
	836	$_[0] =~ s/0-9a-za-z_/\\w/ig;
	837	$_[0] =~ s/\[\\w\]/\\w/g;
	838	$_[0] =~ s/\[^\\w\]/\\W/g;
	839	$_[0] =~ s/\[0-9\]/\\d/g;
	840	$_[0] =~ s/\[^0-9\]/\\D/g;
	841	$_[0] =~ s/\\d\\d\*/\\d+/g;
	842	$_[0] =~ s/\\D\\D\*/\\D+/g;
	843	$_[0] =~ s/\\w\\w\*/\\w+/g;
	844	$_[0] =~ s/\\t\\t\*/\\t+/g;
	845	$_[0] =~ s/(\[.[^]]\])\1\/$1+/g;
	846	$_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
	847	}
	848
a687059c	849	!NO!SUBS!
4633a7c4 LW	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 ':';