App-s2p
view release on metacpan or search on metacpan
my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code, $Func );
$Code = '';
##################
# Compile Time
#
# Labels
#
# Error handling
#
sub Warn($;$){
my( $msg, $loc ) = @_;
$loc ||= '';
$loc .= ': ' if length( $loc );
warn( "$0: $loc$msg\n" );
}
$labNum = 0;
sub newLabel(){
return 'L_'.++$labNum;
}
# safeHere: create safe here delimiter and modify opcode and argument
#
sub safeHere($$){
my( $codref, $argref ) = @_;
my $eod = 'EOD000';
while( $$argref =~ /^$eod$/m ){
$eod++;
}
$$codref =~ s/TheEnd/$eod/e;
$$argref .= "$eod\n";
}
# Emit: create address logic and emit command
#
sub Emit($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
my $cond = '';
if( defined( $addr1 ) ){
if( defined( $addr2 ) ){
$addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
} else {
$addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
}
$cond = $negated ? "unless( $addr1 )\n" : "if( $addr1 )\n";
}
$Code .= "$cond$opcode$arg";
} else {
$Code .= "$cond$opcode\n";
}
0;
}
# Write (w command, w flag): store pathname
#
sub Write($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $path, $fl ) = @_;
$wFiles{$path} = '';
Emit( $addr1, $addr2, $negated, $opcode, $path, $fl );
}
# Label (: command): label definition
#
sub Label($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
my $rc = 0;
$lab =~ s/\s+//;
if( length( $lab ) ){
my $h;
if( ! exists( $Label{$lab} ) ){
$h = $Label{$lab}{name} = newLabel();
} else {
$h = $Label{$lab}{name};
if( exists( $Label{$lab}{defined} ) ){
}
}
$Label{$lab}{defined} = $fl;
$Code .= "$h:;\n";
}
$rc;
}
# BeginBlock ({ command): push block start
#
sub BeginBlock($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
push( @BlockStack, [ $fl, $addr1, $addr2, $negated ] );
Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
}
# EndBlock (} command): check proper nesting
#
sub EndBlock($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
my $rc;
my $jcom = pop( @BlockStack );
if( defined( $jcom ) ){
$rc = Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
} else {
Warn( "unexpected '}'", $fl );
$rc = 1;
}
$rc;
}
# Branch (t, b commands): check or create label, substitute default
#
sub Branch($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
$lab =~ s/\s+//; # no spaces at end
my $h;
if( length( $lab ) ){
if( ! exists( $Label{$lab} ) ){
$h = $Label{$lab}{name} = newLabel();
} else {
$h = $Label{$lab}{name};
}
push( @{$Label{$lab}{used}}, $fl );
} else {
$h = 'EOS';
}
$opcode =~ s/XXX/$h/e;
Emit( $addr1, $addr2, $negated, $opcode, '', $fl );
}
# Change (c command): is special due to range end watching
#
sub Change($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
my $kwd = $negated ? 'unless' : 'if';
if( defined( $addr2 ) ){
$addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
if( ! $negated ){
$addr1 = '$icnt = ('.$addr1.')';
$opcode = 'if( $icnt =~ /E0$/ )' . $opcode;
}
} else {
$addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
}
safeHere( \$opcode, \$arg );
$Code .= "$kwd( $addr1 ){\n $opcode$arg}\n";
0;
}
# Comment (# command): A no-op. Who would've thought that!
#
sub Comment($$$$$$){
my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
### $Code .= "# $arg\n";
0;
}
# stripRegex from the current command. If we're in the first
# part of s///, trailing spaces have to be kept as the initial
# part of the replacement string.
#
sub stripRegex($$;$){
my( $del, $sref, $sub ) = @_;
my $regex = $del;
print "stripRegex:$del:$$sref:\n" if $useDEBUG;
while( $$sref =~ s{^(.*?)(\\*)\Q$del\E(\s*)}{}s ){
my $sl = $2;
$regex .= $1.$sl.$del;
if( length( $sl ) % 2 == 0 ){
if( $sub && (length( $3 ) > 0) ){
$$sref = $3 . $$sref;
}
return $regex;
}
$regex .= $3;
}
undef();
}
# stripTrans: take a <del> terminated string from y command
# honoring and cleaning up of \-escaped <del>'s
#
sub stripTrans($$){
my( $del, $sref ) = @_;
my $t = '';
print "stripTrans:$del:$$sref:\n" if $useDEBUG;
while( $$sref =~ s{^(.*?)(\\*)\Q$del\E}{}s ){
my $sl = $2;
$t .= $1;
if( length( $sl ) % 2 == 0 ){
$t .= $sl;
$t =~ s/\\\\/\\/g;
return $t;
}
chop( $sl );
$t .= $sl.$del.$3;
}
undef();
}
# makey - construct Perl y/// from sed y///
#
sub makey($$$){
my( $fr, $to, $fl ) = @_;
my $error = 0;
# Ensure that any '-' is up front.
# Diagnose duplicate contradicting mappings
my %tr;
for( my $i = 0; $i < length($fr); $i++ ){
my $fc = substr($fr,$i,1);
my $tc = substr($to,$i,1);
if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){
$fr =~ s/([{}])/\$1/g;
$to =~ s/([{}])/\$1/g;
$fr =~ s/\n/\\n/g;
$to =~ s/\n/\\n/g;
return $error ? undef() : "{ y{$fr}{$to}; }";
}
######
# makes - construct Perl s/// from sed s///
#
sub makes($$$$$$$){
my( $regex, $subst, $path, $global, $print, $nmatch, $fl ) = @_;
# make embedded newlines safe
$regex =~ s/\n/\\n/g;
$subst =~ s/\n/\\n/g;
my $code;
# n-th occurrence
#
if( length( $nmatch ) ){
To enable this feature, the environment variable PSEDEXTBRE must be set
to a string containing the requested characters, e.g.:
C<PSEDEXTBRE='E<lt>E<gt>wW'>.
=cut
#####
# bre2p - convert BRE to Perl RE
#
sub peek(\$$){
my( $pref, $ic ) = @_;
$ic < length($$pref)-1 ? substr( $$pref, $ic+1, 1 ) : '';
}
sub bre2p($$$){
my( $del, $pat, $fl ) = @_;
my $led = $del;
$led =~ tr/{([</})]>/;
$led = '' if $led eq $del;
$pat = substr( $pat, 1, length($pat) - 2 );
my $res = '';
my $bracklev = 0;
my $backref = 0;
my $parlev = 0;
# final cleanup: eliminate raw HTs
$res =~ s/\t/\\t/g;
return $del . $res . ( $led ? $led : $del );
}
#####
# sub2p - convert sed substitution to Perl substitution
#
sub sub2p($$$){
my( $del, $subst, $fl ) = @_;
my $led = $del;
$led =~ tr/{([</})]>/;
$led = '' if $led eq $del;
$subst = substr( $subst, 1, length($subst) - 2 );
my $res = '';
for( my $ic = 0; $ic < length( $subst ); $ic++ ){
my $c = substr( $subst, $ic, 1 );
$res .= $c;
}
}
# final cleanup: eliminate raw HTs
$res =~ s/\t/\\t/g;
return ( $led ? $del : $led ) . $res . ( $led ? $led : $del );
}
sub Parse(){
my $error = 0;
my( $pdef, $pfil, $plin );
for( my $icom = 0; $icom < @Commands; $icom++ ){
my $cmd = $Commands[$icom];
print "Parse:$cmd:\n" if $useDEBUG;
$cmd =~ s/^\s+//;
next unless length( $cmd );
my $scom = $icom;
if( exists( $Defined{$icom} ) ){
$pdef = $Defined{$icom};
}
exit( 1 ) if $error;
}
##############
#### MAIN ####
##############
sub usage(){
print STDERR "Usage: sed [-an] command [file...]\n";
print STDERR " [-an] [-e command] [-f script-file] [file...]\n";
}
###################
# Here we go again...
#
my $expr = 0;
while( @ARGV && $ARGV[0] =~ /^-(.)(.*)$/ ){
my $opt = $1;
}
print STDERR "Files: @ARGV\n" if $useDEBUG;
# generate leading code
#
$Func = <<'[TheEnd]';
# openARGV: open 1st input file
#
sub openARGV(){
unshift( @ARGV, '-' ) unless @ARGV;
my $file = shift( @ARGV );
open( ARG, "<$file" )
|| die( "$0: can't open $file for reading ($!)\n" );
$isEOF = 0;
}
# getsARGV: Read another input line into argument (default: $_).
# Move on to next input file, and reset EOF flag $isEOF.
sub getsARGV(;\$){
my $argref = @_ ? shift() : \$_;
while( $isEOF || ! defined( $$argref = <ARG> ) ){
close( ARG );
return 0 unless @ARGV;
my $file = shift( @ARGV );
open( ARG, "<$file" )
|| die( "$0: can't open $file for reading ($!)\n" );
$isEOF = 0;
}
1;
}
# eofARGV: end-of-file test
#
sub eofARGV(){
return @ARGV == 0 && ( $isEOF = eof( ARG ) );
}
# makeHandle: Generates another file handle for some file (given by its path)
# to be written due to a w command or an s command's w flag.
sub makeHandle($){
my( $path ) = @_;
my $handle;
if( ! exists( $wFiles{$path} ) || $wFiles{$path} eq '' ){
$handle = $wFiles{$path} = gensym();
if( $doOpenWrite ){
if( ! open( $handle, ">$path" ) ){
die( "$0: can't open $path for writing: ($!)\n" );
}
}
} else {
$handle = $wFiles{$path};
}
return $handle;
}
# printQ: Print queued output which is either a string or a reference
# to a pathname.
sub printQ(){
for my $q ( @Q ){
if( ref( $q ) ){
# flush open w files so that reading this file gets it all
if( exists( $wFiles{$$q} ) && $wFiles{$$q} ne '' ){
open( $wFiles{$$q}, ">>$$q" );
}
# copy file to stdout: slow, but safe
if( open( RF, "<$$q" ) ){
while( defined( my $line = <RF> ) ){
print $line;
}
}
undef( @Q );
}
[TheEnd]
# generate the sed loop
#
$Code .= <<'[TheEnd]';
sub openARGV();
sub getsARGV(;\$);
sub eofARGV();
sub printQ();
# Run: the sed loop reading input and applying the script
#
sub Run(){
my( $h, $icnt, $s, $n );
# hack (not unbreakable :-/) to avoid // matching an empty string
my $z = "\000"; $z =~ /$z/;
# Initialize.
openARGV();
$Hold = '';
$CondReg = 0;
$doPrint = $doAutoPrint;
CYCLE:
while( getsARGV() ){
# append optional functions, prepend prototypes
#
my $Proto = "# prototypes\n";
if( $GenKey{'l'} ){
$Proto .= "sub _l();\n";
$Func .= <<'[TheEnd]';
# _l: l command processing
#
sub _l(){
my $h = $_;
my $mcpl = 70;
# transform non printing chars into escape notation
$h =~ s/\\/\\\\/g;
if( $h =~ /[^[:print:]]/ ){
$h =~ s/\a/\\a/g;
$h =~ s/\f/\\f/g;
$h =~ s/\n/\\n/g;
$h =~ s/\t/\\t/g;
$h =~ s/\r/\\r/g;
}
[TheEnd]
}
if( $GenKey{'r'} ){
$Proto .= "sub _r(\$);\n";
$Func .= <<'[TheEnd]';
# _r: r command processing: Save a reference to the pathname.
#
sub _r($){
my $path = shift();
push( @Q, \$path );
}
[TheEnd]
}
if( $GenKey{'t'} ){
$Proto .= "sub _t();\n";
$Func .= <<'[TheEnd]';
# _t: t command - condition register test/reset
#
sub _t(){
my $res = $CondReg;
$CondReg = 0;
$res;
}
[TheEnd]
}
if( $GenKey{'w'} ){
$Proto .= "sub _w(\$);\n";
$Func .= <<'[TheEnd]';
# _w: w command and s command's w flag - write to file
#
sub _w($){
my $path = shift();
my $handle = $wFiles{$path};
if( ! $doOpenWrite && ! defined( fileno( $handle ) ) ){
open( $handle, ">$path" )
|| die( "$0: $path: cannot open ($!)\n" );
}
print $handle $_, "\n";
}
[TheEnd]
use Symbol;
use vars qw{ \$isEOF \$Hold \%wFiles \@Q \$CondReg
\$doAutoPrint \$doOpenWrite \$doPrint };
\$doAutoPrint = $doAutoPrint;
\$doOpenWrite = $doOpenWrite;
TheEnd
my $wf = "'" . join( "', '", keys( %wFiles ) ) . "'";
if( $wf ne "''" ){
print <<TheEnd;
sub makeHandle(\$);
for my \$p ( $wf ){
exit( 1 ) unless makeHandle( \$p );
}
TheEnd
}
print $Code;
print "Run();\n";
print $Func;
exit( 0 );
( run in 1.534 second using v1.01-cache-2.11-cpan-65fba6d93b7 )