File Coverage

blib/lib/MarpaX/Database/Terminfo/String/Grammar/Actions.pm

Criterion	Covered	Total	%
statement	55	231	23.8
branch	26	106	24.5
condition	2	7	28.5
subroutine	15	42	35.7
pod	35	35	100.0
total	133	421	31.5

use strict;
use warnings FATAL => 'all';

package MarpaX::Database::Terminfo::String::Grammar::Actions;
use Carp qw/croak/;
use Log::Any qw/$log/;

# ABSTRACT: Terminfo grammar actions

our $VERSION = '0.010'; # VERSION



sub new {
    my $class = shift;
    my $self = {_level => 0};
    bless($self, $class);
    return $self;
}

sub _doPushLevel {
    my ($self) = @_;

    $self->{_level}++;
    return "my \$rc = '';";
}

sub _doEndLevel {
    my ($self) = @_;

    $self->{_level}--;
    return "\$rc;";
}


sub addEscapedCharacterToRc {
    my ($self, $c) = @_;

    if ($log->is_trace) {
	$log->tracef('addEscapedCharacterToRc(c="%s")', $c);
    }

    return "\$rc .= " . $self->_escapedCharacter($c) . "; # $c";
}

sub _escapedCharacter {
    my ($self, $c) = @_;

    if ($log->is_trace) {
	$log->tracef('_escapedCharacter(c="%s")', $c);
    }

    if    ($c eq '\\E' || $c eq '\\e') { return "\"\\e\"";  }
    elsif ($c eq '\\a'               ) { return "\"\\a\"";  }
    elsif ($c eq '\\n'               ) { return "\"\\n\"";  }
    elsif ($c eq '\\l'               ) { return "\"\\n\"";  }
    elsif ($c eq '\\r'               ) { return "\"\\r\"";  }
    elsif ($c eq '\\b'               ) { return "\"\\b\"";  }
    elsif ($c eq '\\f'               ) { return "\"\\f\"";  }
    elsif ($c eq '\\t'               ) { return "\"\\t\"";  }
    elsif ($c eq '\\s'               ) { return "' '";      }
    elsif ($c eq '\\^'               ) { return "'^'";      }
    elsif ($c eq '\\\\'              ) { return "'\\\\'";   }
    elsif ($c eq '\\,'               ) { return "','";      }
    elsif ($c eq '\\:'               ) { return "':'";      }
    # In perl \0 is not the end of a string
    elsif ($c eq '\\0'               ) { return "\"\\0\""; }

    elsif (substr($c, 0, 1) eq '^') {
	#
	# In perl, control-X is \cX, we support the ASCII C0 set + DEL.
	# i.e. the range [@A-Z[\]^_?] (c.f. Marpa grammar).
	# They can ALL be translated litteraly except \c\ that has to be
	# writen as \c\X in perl. Then we remove the last X.
	#
	my $this = $c;
	substr($this, 0, 1, '');
	if ($this eq '\\') {
	    return "\"\\c\\X\"; substr(\$rc, -1, 1, '')";
	} else {
	    return "\"\\c$this\"";
	}
    }
    elsif (substr($c, 0, 1) eq '\\') {
	#
	# Spec says this must be octal digits
	#
	my $oct = $c;
	substr($oct, 0, 1, '');
	$oct =~ s/^0*//;          # Take care... oct(012) == oct(12) = 10 ...
	# Note: in perl \0 is NOT the end of a string
	return "chr(oct($oct))";
    }
    else {
	croak "Unhandled escape sequence $c\n";
    }
}


sub addCharacterToRc {
    my ($self, $c) = @_;

    if ($log->is_trace) {
	$log->tracef('addCharacterToRc(c="%s")', $c);
    }
    #
    # If we quotemeta, then we have to use double quotes
    #
    return "\$rc .= \"" . quotemeta($c) . "\"; # $c";
}


sub addPercentToRc {
    my ($self, $c) = @_;

    if ($log->is_trace) {
	$log->tracef('addPercentToRc(c="%s")', $c);
    }

    return "\$rc .= '%'; # $c";
}


sub addPrintPopToRc {
    my ($self, $c) = @_;

    if ($log->is_trace) {
	$log->tracef('addPrintPopToRc(c="%s")', $c);
    }

    return "\$rc .= sprintf('%c', pop(\@iparam)); # $c";
}


sub addPrintToRc {
    my ($self, $format) = @_;

    if ($log->is_trace) {
	$log->tracef('addPrintToRc(format="%s")', $format);
    }

    #
    # print has the following format:
    # %[[:]flags][width[.precision]][doxXs]
    # => we remove the eventual ':' after the '%'
    # the rest is totally functional within perl
    #
    $format =~ s/^%:/%/;

    return "\$rc .= sprintf('$format', pop(\@iparam)); # $format";
}


sub addPushToRc {
    my ($self, $push) = @_;
    # %p[1-9]

    if ($log->is_trace) {
	$log->tracef('addpushToRc(push="%s")', $push);
    }

    my $indice = ord(substr($push, -1, 1)) - ord('0') - 1;
    return "push(\@iparam, \$param[$indice]); # $push";
}


sub addDynPop {
    my ($self, $dynpop) = @_;
    # %P[a-z]

    if ($log->is_trace) {
	$log->tracef('addDynPop(dynpop="%s")', $dynpop);
    }

    my $indice = ord(substr($dynpop, -1, 1)) - ord('a');
    return "\$dynamicp->[$indice] = pop(\@iparam); # $dynpop";
}


sub addDynPush {
    my ($self, $dynpush) = @_;
    # %g[a-z]

    if ($log->is_trace) {
	$log->tracef('addDynPush(dynpush="%s")', $dynpush);
    }

    my $indice = ord(substr($dynpush, -1, 1)) - ord('a');
    return "push(\@iparam, \$dynamicp->[$indice]); # $dynpush";
}


sub addStaticPop {
    my ($self, $staticpop) = @_;
    # %P[A-Z]

    if ($log->is_trace) {
	$log->tracef('addStaticPop(staticpop="%s")', $staticpop);
    }

    my $indice = ord(substr($staticpop, -1, 1)) - ord('A');
    return "\$staticp->[$indice] = pop(\@iparam); # $staticpop";
}


sub addStaticPush {
    my ($self, $staticpush) = @_;
    # %g[A-Z]

    if ($log->is_trace) {
	$log->tracef('addStaticPush(staticpush="%s")', $staticpush);
    }

    my $indice = ord(substr($staticpush, -1, 1)) - ord('A');
    return "push(\@iparam, \$staticp->[$indice]); # $staticpush";
}


sub addL {
    my ($self, $l) = @_;
    # %l

    if ($log->is_trace) {
	$log->tracef('addL(l="%s")', $l);
    }

    return "push(\@iparam, strlen(pop(\@iparam)); # $l";
}


sub addPushConst {
    my ($self, $const) = @_;
    # %'c'

    if ($log->is_trace) {
	$log->tracef('addPushConst(const="%s")', $const);
    }

    #
    # Either this is an escaped number \ddd, or anything but a quote
    #
    my $inside = $const;
    substr($inside, 0, 2, '');   # Remove %' at the beginning
    substr($inside, -1, 1, '');  # Remove ' at the end

    if (substr($inside, 0, 1) eq '\\') {
	return "push(\@iparam, " . $self->_escapedCharacter($inside) . "); # $const";
    } else {
	return "push(\@iparam, \"" . quotemeta($inside) . "\"); # $const";
    }
}


sub addPushInt {
    my ($self, $int) = @_;
    # %{nn}

    if ($log->is_trace) {
	$log->tracef('addPushInt(int="%s")', $int);
    }

    my $value = $int;
    substr($value, 0, 2, '');
    substr($value, -1, 1, '');

    return "push(\@iparam, $value); # $int";
}


sub addPlus {
    my ($self, $plus) = @_;
    # %+

    if ($log->is_trace) {
	$log->tracef('addPlus(plus="%s")', $plus);
    }

    return "push(\@iparam, pop(\@iparam) + pop(\@iparam)); # $plus";
}


sub addMinus {
    my ($self, $minus) = @_;
    # %+

    if ($log->is_trace) {
	$log->tracef('addMinus(minus="%s")', $minus);
    }

    return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x - \$y); } # $minus";
}


sub addStar {
    my ($self, $star) = @_;
    # %+

    if ($log->is_trace) {
	$log->tracef('addStar(star="%s")', $star);
    }

    return "push(\@iparam, pop(\@iparam) * pop(\@iparam)); # $star";
}


sub addDiv {
    my ($self, $div) = @_;
    # %+

    if ($log->is_trace) {
	$log->tracef('addDiv(div="%s")', $div);
    }

    return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$y ? int(\$x / \$y) : 0); } # $div";
}


sub addMod {
    my ($self, $mod) = @_;
    # %+

    if ($log->is_trace) {
	$log->tracef('addMod(mod="%s")', $mod);
    }

    return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$y ? int(\$x % \$y) : 0); } # $mod";
}


sub addBitAnd {
    my ($self, $bitAnd) = @_;
    # %&

    if ($log->is_trace) {
	$log->tracef('addBitAnd(bitAnd="%s")', $bitAnd);
    }

    return "push(\@iparam, pop(\@iparam) & pop(\@iparam)); # $bitAnd";
}


sub addBitOr {
    my ($self, $bitOr) = @_;
    # %|

    if ($log->is_trace) {
	$log->tracef('addBitOr(bitOr="%s")', $bitOr);
    }

    return "push(\@iparam, pop(\@iparam) | pop(\@iparam)); # $bitOr";
}


sub addBitXor {
    my ($self, $bitXor) = @_;
    # %^

    if ($log->is_trace) {
	$log->tracef('addBitXor(bitXor="%s")', $bitXor);
    }

    return "push(\@iparam, pop(\@iparam) ^ pop(\@iparam)); # $bitXor";
}


sub addEqual {
    my ($self, $equal) = @_;
    # %=

    if ($log->is_trace) {
	$log->tracef('addEqual(equal="%s")', $equal);
    }

    return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x == \$y); } # $equal";
}


sub addGreater {
    my ($self, $greater) = @_;
    # %>

    if ($log->is_trace) {
	$log->tracef('addGreater(greater="%s")', $greater);
    }

    return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x > \$y); } # $greater";
}


sub addLower {
    my ($self, $lower) = @_;
    # %<

    if ($log->is_trace) {
	$log->tracef('addLower(lower="%s")', $lower);
    }

    return "{ my \$y = pop(\@iparam); my \$x = pop(\@iparam); push(\@iparam, \$x < \$y); } # $lower";
}


sub addLogicalAnd {
    my ($self, $logicalAnd) = @_;
    # %A

    if ($log->is_trace) {
	$log->tracef('addLogicalAnd(logicalAnd="%s")', $logicalAnd);
    }

    return "push(\@iparam, pop(\@iparam) && pop(\@iparam)); # $logicalAnd";
}


sub addLogicalOr {
    my ($self, $logicalOr) = @_;
    # %O

    if ($log->is_trace) {
	$log->tracef('addLogicalOr(logicalOr="%s")', $logicalOr);
    }

    return "push(\@iparam, pop(\@iparam) || pop(\@iparam)); # $logicalOr";
}


sub addNot {
    my ($self, $not) = @_;
    # %!

    if ($log->is_trace) {
	$log->tracef('addNot(not="%s")', $not);
    }

    return "push(\@iparam, ! pop(\@iparam)); # $not";
}


sub addComplement {
    my ($self, $complement) = @_;
    # %!

    if ($log->is_trace) {
	$log->tracef('addComplement(complement="%s")', $complement);
    }

    return "push(\@iparam, ~ pop(\@iparam)); # $complement";
}


sub addOneToParams {
    my ($self, $one) = @_;
    # %i

    if ($log->is_trace) {
	$log->tracef('addOneToParams(one="%s")', $one);
    }

    return "map {\$param[\$_]++} (0..\$#param); # $one";
}


sub addIfThenElse {
    my ($self, $if, $units1p, $then, $units2p, $elsifUnitsp, $else, $units3p, $endif) = @_;

    if ($log->is_trace) {
	$log->tracef('addIfThenElse($if="%s", $units1p="%s", $then="%s", $units2p="%s", $elsifUnitsp="%s", $else="%s", $units3p="%s", $endif="%s")', $if, $units1p, $then, $units2p, $elsifUnitsp, $else, $units3p, $endif);
    }

    my $units1     = join("\n", @{$units1p});
    my $units2     = join("\n", @{$units2p});
    my $elsifUnits = join("\n", @{$elsifUnitsp});
    my $units3     = join("\n", @{$units3p});
    #
    # We increase indentation of units
    #
    $units1     =~ s/^/         /smg;
    $units2     =~ s/^/  /smg;
    $units3     =~ s/^/  /smg;
    #
    # $endif can be the EOF
    #
    $endif ||= 'implicit by eof';

    my $rc = "if (do { # $if
$units1
         pop(\@iparam);
       }) { # $then
$units2
}";
    if ($elsifUnits) {
	$rc .= "\n$elsifUnits";
    }
    $rc .= "
else { # $else
$units3
} # $endif";

    return $rc;
}


sub addIfThen {
    my ($self, $if, $units1p, $then, $units2p, $elsifUnitsp, $endif) = @_;

    if ($log->is_trace) {
	$log->tracef('addIfThen($if="%s", $units1p="%s", $then="%s", $units2p="%s", $elsifUnitsp="%s", $endif="%s")', $if, $units1p, $then, $units2p, $elsifUnitsp, $endif);
    }

    my $units1     = join("\n", @{$units1p});
    my $units2     = join("\n", @{$units2p});
    my $elsifUnits = join("\n", @{$elsifUnitsp});
    #
    # We increase indentation of units
    #
    $units1     =~ s/^/         /smg;
    $units2     =~ s/^/  /smg;
    #
    # $endif can be the EOF
    #
    $endif ||= 'implicit by eof';

    my $rc = "if (do { # $if
$units1
         pop(\@iparam);
       }) { # $then
$units2
} # $endif";
    if ($elsifUnits) {
	$rc .= "\n$elsifUnits";
    }

    return $rc;
}


sub elifUnit {
    my ($self, $else, $units1p, $then, $units2p) = @_;

    if ($log->is_trace) {
	$log->tracef('elifUnit($else="%s", $units1p="%s", $then="%s", $units2p="%s")', $else, $units1p, $then, $units2p);
    }
    my $units1     = join("\n", @{$units1p});
    my $units2     = join("\n", @{$units2p});
    #
    # We increase indentation of units
    #
    $units1     =~ s/^/            /smg;
    $units2     =~ s/^/  /smg;

    my $rc = "elsif (do { # $else
$units1
            pop(\@iparam);
       }) { # $then
$units2
}";

    return $rc;
}


sub eof {
    my ($self, @args) = @_;

    return '';
}


sub ifEndif {
    my ($self, @args) = @_;

    return '# IF/ENDIF ignored';
}

1;

__END__