File Coverage

blib/lib/PJVM/Class.pm

Criterion	Covered	Total	%
statement	75	75	100.0
branch	7	12	58.3
condition	2	3	66.6
subroutine	11	11	100.0
pod	0	5	0.0
total	95	106	89.6

package PJVM::Class;

use strict;
use warnings;

use PJVM::Class::ConstantPool;
use PJVM::Class::Field;
use PJVM::Class::Method;

use Object::Tiny qw(
    constant_pool
    access_flags
    this_class
    super_class
    interfaces_classes
    fields
    methods
    attributes
);

sub new_from_io {
    my ($pkg, $io) = @_;

    my $buff;

    my $self = $pkg->new();

    # Check that's it is actually a class file
    read $io, $buff, 4;
    die "Not a classfile" unless sprintf("%x", unpack("N", $buff)) eq "cafebabe";

    # TODO: Blah blah blah.. version compliance crap, let's skip this for now and
    # maybe sometime in the future do something with it.
    read $io, $buff, 4;

    # Constant pool count.. here lies our constants, ie class names etc.
    my $cp = PJVM::Class::ConstantPool->new_from_io($io);
    $self->{constant_pool} = $cp;

    # Access flags (you know, public etc...)
    read $io, $buff, 2;
    my $access_flags = unpack("n", $buff);
    $self->{access_flags} = $access_flags,

    # Name of class and parent
    read $io, $buff, 4;
    my ($this_class, $super_class) = unpack("nn", $buff);
    $self->{this_class} = $this_class,
    $self->{super_class} = $super_class,

    # Read interfaces
    read $io, $buff, 2;
    my $interface_count = unpack("n", $buff);
    my @interfaces;
    if ($interface_count) {
        read $io, $buff, 2 * $interface_count;
        @interfaces = unpack("n*", $buff);
    }
    $self->{interfaces_classes} = \@interfaces,

    # Read fields
    read $io, $buff, 2;
    my $fields_count = unpack("n", $buff);
    my @fields;
    if ($fields_count) {
        while ($fields_count--) {
            push @fields, PJVM::Class::Field->new_from_io($io, $cp, $self);
        }
    }
    $self->{fields} = \@fields,

    # Read methods
    read $io, $buff, 2;
    my $methods_count = unpack("n", $buff);
    my @methods;
    if ($methods_count) {
        while ($methods_count--) {
            push @methods, PJVM::Class::Method->new_from_io($io, $cp, $self);
        }
    }
    $self->{methods} = \@methods,

    # Attributes
    read $io, $buff, 2;
    my $attributes_count = unpack("n", $buff);

    # Read attributes
    my @attributes;
    if ($attributes_count) {
        while ($attributes_count--) {
            push @attributes, PJVM::Class::Attribute->new_from_io($io, $cp);
        }
    }
    $self->{attributes} = \@attributes,

    return $self;
}

# TODO: Optimize since this will probablly be called mucho tiempo
sub method {
    my ($self, $name, $signature) = @_;

    for my $method (@{$self->methods}) {
        if ($method->name eq $name && $method->signature eq $signature) {
            return $method;
        }
    }
}

sub name {
    my $self = shift;
    my $class = $self->constant_pool->get($self->this_class);
    my $name = $self->constant_pool->get($class->name_index);

    return $name->value;
}

sub super {
    my $self = shift;
    my $class = $self->constant_pool->get($self->super_class);
    my $name = $self->constant_pool->get($class->name_index);

    return $name->value;
}

sub interfaces {
    my $self = shift;
    my @names = map {
        my $class = $self->constant_pool->get($_);
        my $name = $self->constant_pool->get($class->name_index);
        $name->value;
    } @{$self->interfaces_classes};

    return @names;
}

1;
__END__