File Coverage

blib/lib/Google/ProtocolBuffers.pm

Criterion	Covered	Total	%
statement	278	293	94.8
branch	66	94	70.2
condition	16	31	51.6
subroutine	43	43	100.0
pod	2	9	22.2
total	405	470	86.1

package Google::ProtocolBuffers;

use 5.008008;
use warnings;
use strict;

use Google::ProtocolBuffers::Codec;
use Google::ProtocolBuffers::Constants qw/:complex_types :labels/;
use Class::Accessor;
use Math::BigInt;
use Carp;
use Data::Dumper;

our $VERSION = "0.11";

sub parsefile {
    my $self = shift;
    my $proto_filename = shift;
    my $opts = shift || {};

    return $self->_parse({file=>$proto_filename}, $opts);
}

sub parse {
    my $self = shift;
    my $proto_text = shift;
    my $opts = shift || {};

    return $self->_parse({text=>$proto_text}, $opts);
}

## Positional access is slightly faster than named one.
## Currently, it's in the same order as text in proto file
## "optional" (LABEL) int32 (type) foo (name) = 1 (number) [default=...]
use constant {
    F_LABEL     => 0,
    F_TYPE      => 1,
    F_NAME      => 2,
    F_NUMBER    => 3,
    F_DEFAULT   => 4,
};

sub _parse {
    my $self = shift;
    my $source = shift;
    my $opts = shift;

    require 'Google/ProtocolBuffers/Compiler.pm';
    my $types = Google::ProtocolBuffers::Compiler->parse($source, $opts);

    ##
    ## 1. Create enums - they will be used as default values for fields
    ##
    my @created_classes;
    while (my ($type_name, $desc) = each %$types) {
        next unless $desc->{kind} eq 'enum';
        my $class_name = $self->_get_class_name_for($type_name, $opts);
        $self->create_enum($class_name, $desc->{fields});
        push @created_classes, $class_name;
    }

    ##
    ## 2. Create groups and messages,
    ## Fill default values of fields and convert their
    ## types (my_package.message_a) into Perl classes names (MyPackage::MessageA)
    ##
    while (my ($type_name, $desc) = each %$types) {
        my $kind = $desc->{kind};
        my @fields;

        if ($kind eq 'enum') {
            next;
        } elsif ($kind eq 'group') {
            push @fields, @{$desc->{fields}};
        } elsif ($kind eq 'message') {
            push @fields, @{$desc->{fields}};

            ##
            ## Get names for extensions fields.
            ## Original (full quilified) name is like 'package.MessageA.field'.
            ## If 'simple_extensions' is true, it will be cut to the last element: 'field'.
            ## Otherwise, it will be enclosed in brackets and all part common to message type
            ## will be removed, e.g. for message 'package.MessageB' it will be '[MessageA.field]'
            ## If message is 'other_package.MessageB', it will be '[package.MessageA.field]'
            ##
            foreach my $e (@{$desc->{extensions}}) {
                my $field_name = $e->[F_NAME];
                my $new_name;
                if ($opts->{simple_extensions}) {
                    $new_name = ($field_name =~ /\.(\w+)$/) ? $1 : $field_name;
                } else {
                    ## remove common identifiers from start of f.q.i.
                    my @type_idents  = split qr/\./, $type_name;
                    my @field_idents = split qr/\./, $field_name;
                    while (@type_idents && @field_idents) {
                        last if $type_idents[0] ne $field_idents[0];
                        shift @type_idents;
                        shift @field_idents;
                    }
                    die "Can't create name for extension field '$field_name' in '$type_name'"
                        unless @field_idents;
                    $new_name = '[' . join('.', @field_idents) . ']';
                }
                $e->[F_NAME] = $new_name;
                push @fields, $e;
            }
        } else {
            die;
        }

        ##
        ## Replace proto type names by Perl classes names
        ##
        foreach my $f (@fields) {
            my $type = $f->[F_TYPE];
            if ($type !~ /^\d+$/) {
                ## not a primitive type
                $f->[F_TYPE] = $self->_get_class_name_for($type, $opts);
            }
        }

        ##
        ## Default values: replace references to enum idents by their values
        ##
        foreach my $f (@fields) {
            my $default_value = $f->[F_DEFAULT];
            if ($default_value && ref $default_value) {
                ## this default value is a literal
                die "Unknown default value " . Data::Dumper::Dumper($default_value)
                    unless ref($default_value) eq 'HASH';
                $f->[F_DEFAULT] = $default_value->{value};
            } elsif ($default_value) {
                ## this default is an enum value
                my ($enum_name, $enum_field_name) = ($default_value =~ /(.*)\.(\w+)$/);
                my $class_name = $self->_get_class_name_for($enum_name, $opts);
                no strict 'refs';
                $f->[F_DEFAULT] = &{"${class_name}::$enum_field_name"};
                use strict;
            }
        }

        ##
        ## Create Perl classes
        ##
        my $class_name = $self->_get_class_name_for($type_name, $opts);
        if ($kind eq 'message') {
            $self->create_message($class_name, \@fields, $opts);
        } elsif ($kind eq 'group') {
            $self->create_group($class_name, \@fields, $opts);
        }
        push @created_classes, $class_name;
    }

    ## Generate Perl code of created classes
    if ($opts->{generate_code}) {
        require 'Google/ProtocolBuffers/CodeGen.pm';
        my $fh;
        if (!ref($opts->{generate_code})) {
            open($fh, ">$opts->{generate_code}")
                or die "Can't write to '$opts->{generate_code}': $!";
        } else {
            $fh = $opts->{generate_code};
        }

        my $package_str = ($opts->{'package_name'}) ?
            "package $opts->{'package_name'};" : "";

        my $source_str = ($source->{'file'}) ?
            "$source->{'file'}" : "inline text";

        print $fh <<"HEADER";
# Generated by the protocol buffer compiler (protoc-perl) DO NOT EDIT!
# source: $source_str

$package_str

use strict;
use warnings;

use Google::ProtocolBuffers;
{
HEADER
        foreach my $class_name (@created_classes) {
            print $fh $class_name->getPerlCode($opts);
        }
        print $fh "}\n1;\n";
    }
    return @created_classes;
}

# Google::ProtocolBuffers->create_message(
#  'AccountRecord',
#  [
#      ## required      string        name  = 1;
#      [LABEL_REQUIRED, TYPE_STRING,  'name', 1 ],
#      [LABEL_OPTIONAL, TYPE_INT32,   'id',   2 ],
#  ],
# );
sub create_message {
    my $self = shift;
    my $class_name = shift;
    my $fields = shift;
    my $opts = shift;

    return $self->_create_message_or_group(
        $class_name, $fields, $opts,
        'Google::ProtocolBuffers::Message'
    );
}

sub create_group {
    my $self = shift;
    my $class_name = shift;
    my $fields = shift;
    my $opts = shift;

    return $self->_create_message_or_group(
        $class_name, $fields, $opts,
        'Google::ProtocolBuffers::Group'
    );
}

sub _create_message_or_group {
    my $self = shift;
    my $class_name = shift;
    my $fields = shift;
    my $opts = shift;
    my $base_class = shift;

    ##
    ## Sanity checks
    ##  1. Class name must be a valid Perl class name
    ##  (should we check that this class doesn't exist yet?)
    ##
    die "Invalid class name: '$class_name'"
        unless $class_name =~ /^[a-z_]\w*(?:::[a-z_]\w*)*$/i;

    ##
    ##
    my (%field_names, %field_numbers);
    foreach my $f (@$fields) {
        my ($label, $type_name, $name, $field_number, $default_value) = @$f;
        die Dumper $f unless $name;

        ##
        ## field names must be valid identifiers and be unique
        ##
        die "Invalid field name: '$name'"
            unless $name && $name =~ /^\[?[a-z_][\w\.]*\]?$/i;
        if ($field_names{$name}++) {
            die "Field '$name' is defined more than once";
        }

        ##
        ## field number must be positive and unique
        ##
        die "Invalid field number: $field_number" unless $field_number>0;
        if ($field_numbers{$field_number}++) {
            die "Field number $field_number is used more than once";
        }

        ## type is either a number (for primitive types)
        ## or a class name. Can't check that complex $type
        ## is valid, because it may not exist yet.
        die "Field '$name' doesn't has a type" unless $type_name;
        if ($type_name =~/^\d+$/) {
            ## ok, this is an ID of primitive type
        } else {
            die "Type '$type_name' is not valid Perl class name"
                unless $type_name =~ /^[a-z_]\w*(?:::[a-z_]\w*)*$/i;
        }

        die "Unknown label value: $label"
            unless $label==LABEL_OPTIONAL || $label==LABEL_REQUIRED || $label==LABEL_REPEATED;
    }


    ## Make a copy of values and sort them so that field_numbers increase,
    ## this is a requirement of protocol
    ## Postitional addressation of field parts is sucks, TODO: replace by hash
    my @field_list               = sort { $a->[F_NUMBER] <=> $b->[F_NUMBER] } map { [@$_] } @$fields;
    my %fields_by_field_name     = map { $_->[F_NAME]   => $_ } @field_list;
    my %fields_by_field_number   = map { $_->[F_NUMBER] => $_ } @field_list;

    no strict 'refs';
    @{"${class_name}::ISA"} = $base_class;
    *{"${class_name}::_pb_fields_list"}         = sub { \@field_list              };
    *{"${class_name}::_pb_fields_by_name"}      = sub { \%fields_by_field_name    };
    *{"${class_name}::_pb_fields_by_number"}    = sub { \%fields_by_field_number  };
    use strict;

    if ($opts->{create_accessors}) {
        no strict 'refs';
        push @{"${class_name}::ISA"}, 'Class::Accessor';
        *{"${class_name}::get"} = \&Google::ProtocolBuffers::get;
        *{"${class_name}::set"} = \&Google::ProtocolBuffers::set;
        use strict;

        if ($opts->{follow_best_practice}) {
            $class_name->follow_best_practice;
        }
        my @accessors = grep { /^[a-z_]\w*$/i } map { $_->[2] } @$fields;
        $class_name->mk_accessors(@accessors);
    }
}

sub create_enum {
    my $self = shift;
    my $class_name = shift;
    my $fields = shift;
    my $options = shift;

    ##
    ## Sanity checks
    ##  1. Class name must be a valid Perl class name
    ##  (should we check that this class doesn't exist yet?)
    ##  2. Field names must be valid identifiers and be unique
    ##
    die "Invalid class name: '$class_name'"
        unless $class_name =~ /^[a-z_]\w*(?:::[a-z_]\w*)*$/i;
    my %names;
    foreach my $f (@$fields) {
        my ($name, $value) = @$f;
        die "Invalid field name: '$name'"
            unless $name && $name =~ /^[a-z_]\w*$/i;
        if ($names{$name}++) {
            die "Field '$name' is defined more than once";
        }
    }

    ## base class and constants export
    no strict 'refs';
    @{"${class_name}::ISA"} = "Google::ProtocolBuffers::Enum";
    %{"${class_name}::EXPORT_TAGS"} = ('constants'=>[]);
    use strict;

    ## create the constants
    foreach my $f (@$fields) {
        my ($name, $value) = @$f;
        no strict 'refs';
        *{"${class_name}::$name"}   = sub { $value };
        push @{ ${"${class_name}::EXPORT_TAGS"}{'constants'} }, $name;
        push @{"${class_name}::EXPORT_OK"}, $name;
        use strict;
    }

    ## create a copy of fields for introspection/code generation
    my @fields = map { [@$_] } @$fields;
    no strict 'refs';
    *{"${class_name}::_pb_fields_list"} = sub { \@fields };

}

##
## Accessors
##
sub getExtension {
    my $self = shift;
    my $data = (ref $self) ? $self : shift();
    my $extension_name = shift;

    $extension_name =~ s/::/./g;
    my $key = "[$extension_name]";

    my $field = $self->_pb_fields_by_name->{$key};
    if ($field) {
        return (exists $data->{$key}) ? $data->{$key} : $field->[F_DEFAULT];
    } else {
        my $class_name = ref $self || $self;
        die "There is no extension '$extension_name' in '$class_name'";
    }
}

sub setExtension {
    my $self = shift;
    my $data = (ref $self) ? $self : shift();
    my $extension_name = shift;
    my $value = shift;

    $extension_name =~ s/::/./g;
    my $key = "[$extension_name]";

    if ($self->_pb_fields_by_name->{$key}) {
        $data->{$key} = $value;
    } else {
        my $class_name = ref $self || $self;
        die "There is no extension '$extension_name' in '$class_name'";
    }
}

##
## This is for Class::Accessor read-accessors, will be
## copied to classes from Message/Group.
## If no value is set, the default one will be returned.
##
sub get {
    my $self = shift;

    if (@_==1) {
    	## checking that $self->{$_[0]} exists is not enough,
    	## since undef value may be set via Class::Accessor's new, e.g:
    	## my $data = My::Message->new({ name => undef })
        return $self->{$_[0]} if defined $self->{$_[0]};
        my $field = $self->_pb_fields_by_name->{$_[0]};
        return $field->[F_DEFAULT];
    } elsif (@_>1) {
    	my @rv;
    	my $fields;
    	foreach my $key (@_) {
    		if (defined $self->{$key}) {
    			push @rv, $self->{$key};
    		} else {
    			$fields ||= $self->_pb_fields_by_name;
    			push @rv, $fields->{$key}->[F_DEFAULT];
    		}
    	}
        return @rv;
    } else {
        Carp::confess("Wrong number of arguments received.");
    }
}

sub set {
    my $self = shift;
    my $key = shift;

    if (@_==1) {
    	if (defined $_[0]) {
    	   $self->{$key} = $_[0];
    	} else {
    		delete $self->{$key};
    	}
    } elsif (@_>1) {
        $self->{$key} = [@_];
    } else {
        Carp::confess("Wrong number of arguments received.");
    }
}

sub _get_class_name_for{
    my $self = shift;
    my $type_name = shift;
    my $opts = shift;

    if ($opts->{no_camel_case}) {
        my $class_name = $type_name;
        $class_name  =~ s/\./::/g;
        return $class_name;
    } else {
        my @idents = split qr/\./, $type_name;
        foreach (@idents) {
            s/_(.)/uc($1)/ge;
            $_ = "\u$_";
        }
        return join("::", @idents);
    }
}

package Google::ProtocolBuffers::Message;
no warnings 'once';
## public
*encode                 = \&Google::ProtocolBuffers::Codec::encode;
*decode                 = \&Google::ProtocolBuffers::Codec::decode;
*setExtension           = \&Google::ProtocolBuffers::setExtension;
*getExtension           = \&Google::ProtocolBuffers::getExtension;
*getPerlCode            = \&Google::ProtocolBuffers::CodeGen::generate_code_of_message_or_group;
## internal
##  _pb_complex_type_kind can be removed and $class->isa('Google::ProtocolBuffers::Message')
##  can be used instead, but current implementation is faster
sub _pb_complex_type_kind { Google::ProtocolBuffers::Constants::MESSAGE() }
#   _pb_fields_list        ## These 3 methods are created in
#   _pb_fields_by_name     ## namespace of derived class
#   _pb_fields_by_number

package Google::ProtocolBuffers::Group;
*setExtension           = \&Google::ProtocolBuffers::setExtension;
*getExtension           = \&Google::ProtocolBuffers::getExtension;
*getPerlCode            = \&Google::ProtocolBuffers::CodeGen::generate_code_of_message_or_group;
sub _pb_complex_type_kind { Google::ProtocolBuffers::Constants::GROUP() }
#_pb_fields_list
#_pb_fields_by_name
#_pb_fields_by_number

package Google::ProtocolBuffers::Enum;
use base 'Exporter';
*getPerlCode            = \&Google::ProtocolBuffers::CodeGen::generate_code_of_enum;
sub _pb_complex_type_kind { Google::ProtocolBuffers::Constants::ENUM() }
#_pb_fields_list

1;

__END__