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

package MarpaX::Java::ClassFile::Role::Parser::Actions;

# ABSTRACT: Grammar actions role for .class file parsing

our $VERSION = '0.003'; # VERSION

our $AUTHORITY = 'cpan:JDDPAUSE'; # AUTHORITY

use Moo::Role;
#
# This package is part of the core of the engine. So it is optimized
# using directly the stack (i.e. no $self)
#
use Math::BigFloat qw//;
use Bit::Vector qw//;
use Scalar::Util qw/blessed/;
use constant {
  FLOAT_POSITIVE_INF => Math::BigFloat->binf(),
  FLOAT_NEGATIVE_INF => Math::BigFloat->binf('-'),
  FLOAT_NAN => Math::BigFloat->bnan(),
  FLOAT_POSITIVE_ONE => Math::BigFloat->new('1'),
  FLOAT_NEGATIVE_ONE => Math::BigFloat->new('-1'),
};


#
# Note: we use Bit::Vector for portability, some steps could have been replaced with unpack
#
sub _bytesToVector {
  my @u1 = map { unpack('C', $_) } split('', $_[1]);
  my $bits = 8 * scalar(@u1);
  #
  # Increase bit numbers by 1 ensure to_Dec() returns the unsigned version
  # Default is to no increase of bit number
  #
  ++$bits if ($_[2]);   # Default is undef
  my $vector = Bit::Vector->new_Dec($bits, shift(@u1));
  while (@u1) {
    $vector->Move_Left(8),
    $vector->Or($vector, Bit::Vector->new_Dec($bits, shift(@u1)))
  }
  $vector
}

# sub u1       { $_[0]->_bytesToVector($_[1], 1)->to_Dec }  # Ask for an unsigned value explicitely
# sub signedU1 { $_[0]->_bytesToVector($_[1]   )->to_Dec }
# sub u2       { $_[0]->_bytesToVector($_[1], 1)->to_Dec }  # Ask for an unsigned value explicitely
sub u1       { unpack('C', $_[1]) }
sub signedU1 { unpack('c', $_[1]) }
sub u2       { unpack('n', $_[1]) }
sub signedU2 { $_[0]->_bytesToVector($_[1]   )->to_Dec }
sub u4       { $_[0]->_bytesToVector($_[1], 1)->to_Dec }  # Ask for an unsigned value explicitely
sub signedU4 { $_[0]->_bytesToVector($_[1],  )->to_Dec }

my @bitsForFloatCmp =
  (
   Bit::Vector->new_Hex( 32, '7f800000' ),
   Bit::Vector->new_Hex( 32, 'ff800000' ),
   Bit::Vector->new_Hex( 32, '7f800001' ),
   Bit::Vector->new_Hex( 32, '7fffffff' ),
   Bit::Vector->new_Hex( 32, 'ff800001' ),
   Bit::Vector->new_Hex( 32, 'ffffffff' )
  );
my @bitsForFloatMantissa =
  (
   Bit::Vector->new_Hex( 32, 'ff'     ),
   Bit::Vector->new_Hex( 32, '7fffff' ),
   Bit::Vector->new_Hex( 32, '800000' )
  );
my @mathForFloat =
  (
   Math::BigFloat->new('150'),
   Math::BigFloat->new('2'),
  );

sub floatToString { $_[0]->double($_[1], $_[2])->bstr() }
sub float {
  my $vector = $_[0]->_bytesToVector($_[1]);

  my $value;
  if ($vector->equal($bitsForFloatCmp[0])) {
    $value = FLOAT_POSITIVE_INF->copy
  }
  elsif ($vector->equal( $bitsForFloatCmp[1])) {
    $value = FLOAT_NEGATIVE_INF->copy
  }
  elsif (
         (
          $vector->Lexicompare( $bitsForFloatCmp[2] ) >= 0  &&
          $vector->Lexicompare( $bitsForFloatCmp[3] ) <= 0
         )
         ||
         (
          $vector->Lexicompare( $bitsForFloatCmp[4] ) >= 0 &&
          $vector->Lexicompare( $bitsForFloatCmp[5] ) <= 0
         )
        ) {
    $value = FLOAT_NAN->copy
  }
  else {
    #
    # int s = ((bits >> 31) == 0) ? 1 : -1;
    #
    my $s = $vector->Clone();
    $s->Move_Right(31);
    my $sf = ($s->to_Dec() == 0) ? FLOAT_POSITIVE_ONE->copy() : FLOAT_NEGATIVE_ONE->copy();
    #
    # int e = ((bits >> 23) & 0xff);
    #
    my $e = $vector->Clone();
    $e->Move_Right(23);
    $e->And( $e, $bitsForFloatMantissa[0] );
    #
    # int m = (e == 0) ? (bits & 0x7fffff) << 1 : (bits & 0x7fffff) | 0x800000;
    #                     ^^^^^^^^^^^^^^^^^^^^^    ^^^^^^^^^^^^^^^^^^^^^^^^^
    #                                       \       /
    #                                        \     /
    #                                      same things
    #
    my $m = $vector->Clone();
    $m->And( $m, $bitsForFloatMantissa[1] );
    if ( $e->to_Dec() == 0 ) {
      $m->Move_Left(1)
    } else {
      $m->Or( $m, $bitsForFloatMantissa[2] )
    }
    #
    # $value = $s * $m * (2 ** ($e - 150))
    # Note: Bit::Vector->to_Dec() returns a string
    my $mf = Math::BigFloat->new($m->to_Dec());
    my $ef = Math::BigFloat->new($e->to_Dec());

    $ef->bsub($mathForFloat[0]);              # $e - 150
    my $mantissaf = $mathForFloat[1]->copy(); # 2
    $mantissaf->bpow($ef);                    # 2 ** ($e - 150)
    $mf->bmul($mantissaf);                    # $m * (2 ** ($e - 150))
    $mf->bmul($sf);                           # $s * $m * (2 ** ($e - 150))
    $value = $mf
  }

  $value
}

sub long {
  my $vhigh = $_[0]->_bytesToVector($_[1]);
  my $vlow  = $_[0]->_bytesToVector($_[2]);
  #
  # ((long) high_bytes << 32) + low_bytes
  #
  Bit::Vector->Concat_List($vhigh, $vlow)->to_Dec()
}

my @bitsForDoubleCmp = (
                       Bit::Vector->new_Hex( 64, "7ff0000000000000" ),
                       Bit::Vector->new_Hex( 64, "fff0000000000000" ),
                       Bit::Vector->new_Hex( 64, "7ff0000000000001" ),
                       Bit::Vector->new_Hex( 64, "7fffffffffffffff" ),
                       Bit::Vector->new_Hex( 64, "fff0000000000001" ),
                       Bit::Vector->new_Hex( 64, "ffffffffffffffff" )
                      );
my @bitsForDoubleMantissa =
  (
   Bit::Vector->new_Hex( 64, '7ff'           ),
   Bit::Vector->new_Hex( 64, 'fffffffffffff' ),
   Bit::Vector->new_Hex( 64, '10000000000000' )
  );
my @mathForDouble =
  (
   Math::BigFloat->new('1075'),
   Math::BigFloat->new('2'),
  );

sub doubleToString { $_[0]->double($_[1], $_[2])->bstr() }
sub double {
  my $vhigh = $_[0]->_bytesToVector($_[1]);
  my $vlow  = $_[0]->_bytesToVector($_[2]);
  #
  # ((long) high_bytes << 32) + low_bytes
  #
  my $vector = Bit::Vector->Concat_List($vhigh, $vlow);
  #
  # Same technique as in float
  #
  my $value;
  if ($vector->equal($bitsForDoubleCmp[0])) {
    $value = FLOAT_POSITIVE_INF->copy
  }
  elsif ($vector->equal( $bitsForDoubleCmp[1])) {
    $value = FLOAT_NEGATIVE_INF->copy
  }
  elsif (
         (
          $vector->Lexicompare( $bitsForDoubleCmp[2] ) >= 0  &&
          $vector->Lexicompare( $bitsForDoubleCmp[3] ) <= 0
         )
         ||
         (
          $vector->Lexicompare( $bitsForDoubleCmp[4] ) >= 0 &&
          $vector->Lexicompare( $bitsForDoubleCmp[5] ) <= 0
         )
        ) {
    $value = FLOAT_NAN->copy
  }
  else {
    #
    # int s = ((bits >> 63) == 0) ? 1 : -1;
    #
    my $s = $vector->Clone();
    $s->Move_Right(63);
    my $sf = ($s->to_Dec() == 0) ? FLOAT_POSITIVE_ONE->copy() : FLOAT_NEGATIVE_ONE->copy();
    #
    # int e = (int)((bits >> 52) & 0x7ffL);
    #
    my $e = $vector->Clone();
    $e->Move_Right(52);
    $e->And( $e, $bitsForDoubleMantissa[0] );
    #
    # long m = (e == 0) ? (bits & 0xfffffffffffffL) << 1 : (bits & 0xfffffffffffffL) | 0x10000000000000L;
    #                     ^^^^^^^^^^^^^^^^^^^^^^^^^        ^^^^^^^^^^^^^^^^^^^^^^^^^
    #                                             \       /
    #                                              \     /
    #                                            same things
    my $m = $vector->Clone();
    $m->And( $m, $bitsForDoubleMantissa[1] );
    if ( $e->to_Dec() == 0 ) {
      $m->Move_Left(1)
    } else {
      $m->Or( $m, $bitsForDoubleMantissa[2] )
    }
    #
    # $value = $s * $m * (2 ** ($e - 1075))
    #
    my $mf = Math::BigFloat->new($m->to_Dec());
    my $ef = Math::BigFloat->new($e->to_Dec());

    $ef->bsub($mathForDouble[0]);              # $e - 1075
    my $mantissaf = $mathForDouble[1]->copy(); # 2
    $mantissaf->bpow($ef);                     # 2 ** ($e - 150)
    $mf->bmul($mantissaf);                     # $m * (2 ** ($e - 150))
    $mf->bmul($sf);                            # $s * $m * (2 ** ($e - 150))
    $value = $mf
  }

  $value
}

sub utf8 {
    #
    # Disable all conversion warnings:
    # either we know we succeed, either we abort -;
    #
    no warnings;

    my @u1 = split('', $_[1]);
    my $s  = @u1 ? '' : undef;
    my ($val0, $val1, $val2, $val3, $val4, $val5);

    while (@u1) {
        #
        # No need to reset the array
        #
        $val0 = unpack( 'C', $u1[0] );
        $_[0]->fatalf('Invalid byte with value %s', $val0) if (($val0 == 0) || (($val0 >= 0xF0) && ($val0 <= 0xFF)));
        #
        # Below x means either 0 or 1
        #
        # 6 bytes ?
        #
        if ($val0 == 0xED) {    # 0xED == 11101101
            if ($#u1 >= 1) {
                $val1 = unpack('C', $u1[1]);
                $_[0]->fatalf('Invalid byte with value %s', $val1) if (($val1 == 0) || (($val1 >= 0xF0) && ($val1 <= 0xFF)));
                if (($val1 & 0xF0) == 0xA0) { # 0xF0 == 11110000, 0xA0 == 10100000
                    if ($#u1 >= 2) {
                        $val2 = unpack('C', $u1[2]);
                        $_[0]->fatalf('Invalid byte with value %s', $val2) if (($val2 == 0) || (($val2 >= 0xF0) && ($val2 <= 0xFF)));
                        if (($val2 & 0xC0) == 0x80) { # 0xC0 == 11000000, 0x80 == 10000000
                            if ($#u1 >= 3) {
                                $val3 = unpack('C', $u1[3]);
                                $_[0]->fatalf('Invalid byte with value %s', $val3) if (($val3 == 0) || (($val3 >= 0xF0) && ($val3 <= 0xFF)));
                                if ($val3 == 0xED) {    # 0xED == 11101101
                                    if ($#u1 >= 4) {
                                        $val4 = unpack('C', $u1[4]);
                                        $_[0]->fatalf('Invalid byte with value %s', $val4) if (($val4 == 0) || (($val4 >= 0xF0) && ($val4 <= 0xFF)));
                                        if (($val4 & 0xF0) == 0xB0) { # 0xF0 == 11110000, 0xA0 == 10110000
                                            if ($#u1 >= 5) {
                                                $val5 = unpack('C', $u1[5]);
                                                $_[0]->fatalf('Invalid byte with value %s', $val2) if (($val5 == 0) || (($val5 >= 0xF0) && ($val5 <= 0xFF)));
                                                if (($val5 & 0xC0) == 0x80) { # 0xC0 == 11000000, 0x80 == 10000000
                                                    #
                                                    # 11101101 1010xxxx 10xxxxxx 11101101 1011xxxx 10xxxxxx: code points above U+FFFF
                                                    #
                                                    $s .= chr(0x10000 +
                                                              (($val1 & 0x0F) << 16) +
                                                              (($val2 & 0x3F) << 10) +
                                                              (($val4 & 0x0F) <<  6) +
                                                               ($val5 & 0x3F)
                                                             );
                                                    splice(@u1, 0, 6);
                                                    next
                                                } else {
                                                  $_[0]->fatalf('Invalid byte with value %s', $val5)
                                                }
                                            } else {
                                              $_[0]->fatalf('Not enough bytes to form a 6-byte modified UTF-8')
                                            }
                                        } else {
                                          $_[0]->fatalf('Invalid byte with value %s', $val4)
                                        }
                                    } else {
                                      $_[0]->fatalf('Not enough bytes to form a 6-byte modified UTF-8')
                                    }
                                } else {
                                  $_[0]->fatalf('Invalid byte with value %s', $val3)
                                }
                            } else {
                              $_[0]->fatalf('Not enough bytes to form a 6-byte modified UTF-8')
                            }
                        } else {
                          $_[0]->fatalf('Invalid byte with value %s', $val2)
                        }
                    } else {
                      $_[0]->fatalf('Not enough bytes to form a 6-byte modified UTF-8')
                    }
                } else {
                  $_[0]->fatalf('Invalid byte with value %s', $val1)
                }
            } else {
              $_[0]->fatalf('Not enough bytes to form a 6-byte modified UTF-8')
            }
        }
        #
        # 3 bytes ?
        #
        elsif (($val0 & 0xF0) == 0xE0) {    # 0xF0 == 11110000, 0xE0 == 11100000
            if ($#u1 >= 1) {
                $val1 = unpack('C', $u1[1]);
                $_[0]->fatalf('Invalid byte with value %s', $val1) if (($val1 == 0) || (($val1 >= 0xF0) && ($val1 <= 0xFF)));
                if (($val1 & 0xC0) == 0x80) {    # 0xC0 == 11000000, 0x80 == 10000000
                    if ($#u1 >= 2) {
                        $val2 = unpack('C', $u1[2]);
                        $_[0]->fatalf('Invalid byte with value %s', $val2) if (($val2 == 0) || (($val2 >= 0xF0) && ($val2 <= 0xFF)));
                        if (($val2 & 0xC0) == 0x80) {    # 0xC0 == 11000000, 0x80 == 10000000
                             #
                             # 1110xxxx 10xxxxxx 10xxxxxx: Code points in the range '\u0800' to '\uFFFF'
                             #
                             $s .= chr( (( $val0 & 0xF ) << 12) + (($val1 & 0x3F) << 6) + ($val2 & 0x3F));
                             splice(@u1, 0, 3);
                             next
                        } else {
                          $_[0]->fatalf('Invalid byte with value %s', $val2)
                        }
                    } else {
                      $_[0]->fatalf('Not enough bytes to form a 3-byte modified UTF-8')
                    }
                } else {
                  $_[0]->fatalf('Invalid byte with value %s', $val1)
                }
            } else {
              $_[0]->fatalf('Not enough bytes to form a 3-byte modified UTF-8')
            }
        }
        #
        # 2 bytes ?
        #
        elsif (($val0 & 0xE0) == 0xC0) {    # 0xE0 == 11100000, 0xC0 == 11000000
            if ($#u1 >= 1) {
                $val1 = unpack('C', $u1[1]);
                $_[0]->fatalf('Invalid byte with value %s', $val1) if (($val1 == 0) || (($val1 >= 0xF0) && ($val1 <= 0xFF)));
                if (($val1 & 0xC0) == 0x80) {    # 0xC0 == 11000000, 0x80 == 10000000
                     #
                     # 110xxxxx 10xxxxxx: null code point ('\u0000') and code points in the range '\u0080' to '\u07FF'
                     #
                     $s .= chr( (($val0 & 0x1F) << 6) + ($val1 & 0x3F));
                     splice(@u1, 0, 2);
                     next
                } else {
                  $_[0]->fatalf('Invalid byte with value %s', $val1)
                }
            } else {
              $_[0]->fatalf('Not enough bytes to form a 2-byte modified UTF-8')
            }
        }
        #
        # 1 byte ?
        #
        elsif (($val0 & 0x80) == 0) {
            #
            # 0xxxxxxx: Code points in the range '\u0001' to '\u007F'
            #
            $s .= chr($val0);
            shift(@u1);
            next
        }
        else {
          $_[0]->fatalf('Unable to map byte with value 0x%x', $val0)
        }
    }

    $s
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

MarpaX::Java::ClassFile::Role::Parser::Actions - Grammar actions role for .class file parsing

=head1 VERSION

version 0.003

=head1 DESCRIPTION

MarpaX::Java::ClassFile::ClassFile::Common::Actions is an internal class used by L<MarpaX::Java::ClassFile::ClassFile>, please refer to the later.

=head1 AUTHOR

Jean-Damien Durand <jeandamiendurand@free.fr>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by Jean-Damien Durand.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
