view release on metacpan or  search on metacpan

lib/Set/SegmentTree/ValueLookup.pm  view on Meta::CPAN

		unshift @objects, { type => 'file_identifier', data => 'RTRE' };

		# header pointer to root data structure
		unshift @objects, { type => "header", data => "\0\0\0\0", reloc => [{ offset => 0, item => $root, type => "unsigned delta" }] };

		return $self->serialize_objects(@objects);
	} else {

		my $vtable = $self->serialize_vtable(
			defined $self->{root} ? 4 : 0,
			defined $self->{nodes} ? 4 : 0,
			defined $self->{created} ? 4 : 0,
		);
		my $data = "\0\0\0\0";

		my @reloc = ({ offset => 0, item => $vtable, type => "signed negative delta" });
		# flatbuffers vtable offset is stored in negative form
		my @objects = ($vtable);

		if (defined $self->{root}) {
			$data .= pack 'l<', $self->{root};
		}

		if (defined $self->{nodes}) {
			my ($array_object, @array_objects) = $self->serialize_array('[Set::SegmentTree::node]', $self->{nodes}, $cache);
			push @objects, $array_object, @array_objects;
			push @reloc, { offset => length ($data), item => $array_object, type => 'unsigned delta'};
			$data .= "\0\0\0\0";
		}

		if (defined $self->{created}) {
			$data .= pack 'l<', $self->{created};
		}

		# pad to 4 byte boundary
		$data .= pack "x" x (4 - (length ($data) % 4)) if length ($data) % 4;

		# return table data and other objects that we've created
		return { type => "table", data => $data, reloc => \@reloc }, @objects
	}
}
	

sub serialize_objects {
	my ($self, @objects) = @_;


	my $data = "";
	my $offset = 0;

	# concatentate the data
	for my $object (@objects) {
		$object->{serialized_offset} = $offset;
		$data .= $object->{data};
		$offset += length $object->{data};
	}

	# second pass for writing offsets to other parts
	for my $object (@objects) {
		if (defined $object->{reloc}) {
			# perform address relocation
			for my $reloc (@{$object->{reloc}}) {
				my $value;
				if (defined $reloc->{lambda}) { # allow the reloc to have a custom format
					$value = $reloc->{lambda}($object, $reloc);
				} elsif (defined $reloc->{type} and $reloc->{type} eq "unsigned delta") {
					$value = pack "L<", $reloc->{item}{serialized_offset} - $object->{serialized_offset} - $reloc->{offset};
				} elsif (defined $reloc->{type} and $reloc->{type} eq "signed negative delta") {
					$value = pack "l<", $object->{serialized_offset} + $reloc->{offset} - $reloc->{item}{serialized_offset};
				} else {
					...
				}
				substr $data, $object->{serialized_offset} + $reloc->{offset}, length($value), $value;
			}
		}
	}

	# done, the data is now ready to be deserialized
	return $data
}

sub serialize_vtable {
	my ($self, @lengths) = @_;

	my $offset = 4;
	my @table;

	for (@lengths) { # parse table offsets
		push @table, $_ ? $offset : 0;
		$offset += $_;
	}

	unshift @table, $offset; # prefix data length
	unshift @table, 2 * (@table + 1); #prefix vtable length
	push @table, 0 if @table % 2; # pad if odd count
	# compile object
	return { type => "vtable", data => pack "S<" x @table, @table }
}

sub serialize_string {
	my ($self, $string) = @_;

	my $len = pack "L<", length $string;
	$string .= "\0"; # null termination byte because why the fuck not (it's part of flatbuffers)

	my $data = "$len$string";
	$data .= pack "x" x (4 - (length ($data) % 4)) if length ($data) % 4; # pad to 4 byte boundary

	return { type => "string", data => $data }
}


sub serialize_array {
	my ($self, $array_type, $array, $cache) = @_;

	$array_type = $array_type =~ s/\A\[(.*)\]\Z/$1/sr;

	my $data = pack "L<", scalar @$array;
	my @array_objects;
	my @reloc;