File Coverage

lib/Geo/LibProj/FFI.pm

Criterion	Covered	Total	%
statement	91	91	100.0
branch	28	28	100.0
condition	12	12	100.0
subroutine	53	53	100.0
pod			n/a
total	184	184	100.0

use 5.012;
use warnings;

# ABSTRACT: Foreign function interface to PROJ coordinate transformation software
package Geo::LibProj::FFI 0.03;


use Alien::proj 1.07;
use FFI::Platypus 1.00;
use FFI::C 0.08;

use Exporter::Easy (TAGS => [
	context => [qw(
		proj_context_create
		proj_context_destroy
		proj_context_use_proj4_init_rules
	)],
	setup => [qw(
		proj_create
		proj_create_argv
		proj_create_crs_to_crs
		proj_create_crs_to_crs_from_pj
		proj_normalize_for_visualization
		proj_destroy
	)],
	transform => [qw(
		proj_trans
	)],
	error => [qw(
		proj_context_errno
		proj_errno_string
		proj_context_errno_string
	)],
	logging => [qw(
		proj_log_level
	)],
	info => [qw(
		proj_info
	)],
	misc => [qw(
		proj_coord
	)],
	const => [qw(
		PJ_DEFAULT_CTX
		PJ_LOG_NONE PJ_LOG_ERROR PJ_LOG_DEBUG PJ_LOG_TRACE PJ_LOG_TELL
		PJ_FWD PJ_IDENT PJ_INV
	)],
	all => [qw(
		:context
		:setup
		:transform
		:error
		:logging
		:info
		:misc
		:const
		proj_cleanup
	)],
]);

my $ffi = FFI::Platypus->new(
	api => 1,
	lang => 'C',
	lib => [Alien::proj->dynamic_libs],
);
FFI::C->ffi($ffi);

$ffi->load_custom_type('::StringArray' => 'string_array');
# string[] should also work, but causes strlen in proj_create_crs_to_crs_from_pj to segfault



# based on proj.h version 8.0.0

# ***************************************************************************
# Copyright (c) 2016, 2017, Thomas Knudsen / SDFE
# Copyright (c) 2018, Even Rouault
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO COORD SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
# ***************************************************************************

# C API new generation

$ffi->type('opaque' => 'PJ_AREA');

# Data type for projection/transformation information
$ffi->type('opaque' => 'PJ');  # the PJ object herself


# Geodetic, mostly spatiotemporal coordinate types
{
	package Geo::LibProj::FFI::PJ_XYZT 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ x y z t }) }
	package Geo::LibProj::FFI::PJ_UVWT 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ u v w t })->uvwt }
	package Geo::LibProj::FFI::PJ_LPZT 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ lam phi z t }) }
	package Geo::LibProj::FFI::PJ_OPK 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ o p k 0 }) }
	# Rotations: omega, phi, kappa
	package Geo::LibProj::FFI::PJ_ENU 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ e n u 0 }) }
	# East, North, Up
	package Geo::LibProj::FFI::PJ_GEOD 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ s a1 a2 0 }) }
	# Geodesic length, fwd azi, rev azi
}

# Classic proj.4 pair/triplet types - moved into the PJ_ name space
{
	package Geo::LibProj::FFI::PJ_UV 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ u v 0 0 })->uv }
	package Geo::LibProj::FFI::PJ_XY 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ x y 0 0 }) }
	package Geo::LibProj::FFI::PJ_LP 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ lam phi 0 0 }) }

	package Geo::LibProj::FFI::PJ_XYZ 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ x y z 0 }) }
	package Geo::LibProj::FFI::PJ_UVW 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ u v w 0 })->uvw }
	package Geo::LibProj::FFI::PJ_LPZ 0.03;
	sub new { Geo::LibProj::FFI::PJ_COORD->_new($_[1], qw{ lam phi z 0 }) }
}


# Data type for generic geodetic 3D data plus epoch information
# Avoid preprocessor renaming and implicit type-punning: Use a union to make it explicit
{
	# FFI::C::Union can't be passed by value due to limitations within
	# FFI::Platypus. Workaround: Use a Record with some additional Perl
	# glue. The performance may not be perfect, but seems satisfactory.

	package Geo::LibProj::FFI::PJ_COORD 0.03;
	use FFI::Platypus::Record;
	record_layout_1(qw{ double x double y double z double t });
	sub _new {
		my ($class, $values, @params) = @_;
		$values //= {};
		@params = map { $values->{$_} // 0 } @params;
		return $class->new({ 'x' => $params[0], 'y' => $params[1], 'z' => $params[2], 't' => $params[3] });
	}
	sub _set {
		my ($self, $values, @params) = @_;
		if (ref $values eq 'HASH') {
			@params = map { $values->{$_} } @params;
		}
		else {
			@params = map { eval "\$values->$_" } grep !/^0$/, @params;  ## no critic (ProhibitStringyEval)
		}
		$self->v(\@params);
	}

	# union members:
	sub v {  # First and foremost, it really is "just 4 numbers in a vector"
		my ($self, $vector) = @_;
		return [ $self->x(), $self->y(), $self->z(), $self->t() ] unless $vector;
		$self->x($vector->[0] // 0);
		$self->y($vector->[1] // 0);
		$self->z($vector->[2] // 0);
		$self->t($vector->[3] // 0);
	}
	sub xyzt { $_[1] ? $_[0]->_set($_[1], qw{ x   y   z  t }) : shift }
	sub uvwt { $_[1] ? $_[0]->_set($_[1], qw{ u   v   w  t }) : Geo::LibProj::FFI::PJ_UVWT->_new(shift) }
	sub lpzt { $_[1] ? $_[0]->_set($_[1], qw{ lam phi z  t }) : shift }
	sub geod { $_[1] ? $_[0]->_set($_[1], qw{ s   a1  a2 0 }) : shift }
	sub opk  { $_[1] ? $_[0]->_set($_[1], qw{ o   p   k  0 }) : shift }
	sub enu  { $_[1] ? $_[0]->_set($_[1], qw{ e   n   u  0 }) : shift }
	sub xyz  { $_[1] ? $_[0]->_set($_[1], qw{ x   y   z  0 }) : shift }
	sub uvw  { $_[1] ? $_[0]->_set($_[1], qw{ u   v   w  0 }) : Geo::LibProj::FFI::PJ_UVWT->_new(shift) }
	sub lpz  { $_[1] ? $_[0]->_set($_[1], qw{ lam phi z  0 }) : shift }
	sub xy   { $_[1] ? $_[0]->_set($_[1], qw{ x   y   0  0 }) : shift }
	sub uv   { $_[1] ? $_[0]->_set($_[1], qw{ u   v   0  0 }) : Geo::LibProj::FFI::PJ_UVWT->_new(shift) }
	sub lp   { $_[1] ? $_[0]->_set($_[1], qw{ lam phi 0  0 }) : shift }

	# struct members:
	# PJ_UV* need their own package due to name collisions.
	# The other types are implemented by the PJ_COORD package.

	sub lam { shift->x( @_ ) }
	sub o   { shift->x( @_ ) }
	sub e   { shift->x( @_ ) }
	sub s   { shift->x( @_ ) }

	sub phi { shift->y( @_ ) }
	sub p   { shift->y( @_ ) }
	sub n   { shift->y( @_ ) }
	sub a1  { shift->y( @_ ) }

	sub k   { shift->z( @_ ) }
	sub u   { shift->z( @_ ) }
	sub a2  { shift->z( @_ ) }

	package Geo::LibProj::FFI::PJ_UVWT;
	use parent -norequire => 'Geo::LibProj::FFI::PJ_COORD';
	sub _new { bless \$_[1], $_[0] }
	sub u { ${shift()}->x( @_ ) }
	sub v { ${shift()}->y( @_ ) }
	sub w { ${shift()}->z( @_ ) }
	sub t { ${shift()}->t( @_ ) }

}
$ffi->type('record(Geo::LibProj::FFI::PJ_COORD)' => 'PJ_COORD');


{
	package Geo::LibProj::FFI::PJ_INFO 0.03;
	use FFI::Platypus::Record;
	record_layout_1(
		int    => 'major',       # Major release number
		int    => 'minor',       # Minor release number
		int    => 'patch',       # Patch level
		string => 'release',     # Release info. Version + date
		string => 'version',     # Full version number
		string => 'searchpath',  # Paths where init and grid files are
		                         # looked for. Paths are separated by
		                         # semi-colons on Windows, and colons
		                         # on non-Windows platforms.
		opaque => 'paths',
		size_t => 'path_count',
	);
}
$ffi->type('record(Geo::LibProj::FFI::PJ_INFO)' => 'PJ_INFO');

FFI::C->enum('PJ_LOG_LEVEL', [
	[PJ_LOG_NONE  => 0],
	[PJ_LOG_ERROR => 1],
	[PJ_LOG_DEBUG => 2],
	[PJ_LOG_TRACE => 3],
	[PJ_LOG_TELL  => 4],
	[PJ_LOG_DEBUG_MAJOR => 2],  # for proj_api.h compatibility
	[PJ_LOG_DEBUG_MINOR => 3],  # for proj_api.h compatibility
], {rev => 'int'});

# The context type - properly namespaced synonym for pj_ctx
$ffi->type('opaque' => 'PJ_CONTEXT');

# A P I

# The objects returned by the functions defined in this section have minimal
# interaction with the functions of the
# iso19111_functions section, and vice versa. See its introduction
# paragraph for more details.

# Functionality for handling thread contexts
use constant PJ_DEFAULT_CTX => 0;
$ffi->attach( proj_context_create => [] => 'PJ_CONTEXT');
$ffi->attach( proj_context_destroy => ['PJ_CONTEXT'] => 'void');

$ffi->attach( proj_context_use_proj4_init_rules => [qw( PJ_CONTEXT int )] => 'void' );

# Manage the transformation definition object PJ
$ffi->attach( proj_create => [qw( PJ_CONTEXT string )] => 'PJ' );
$ffi->attach( proj_create_argv => [qw( PJ_CONTEXT int string_array )] => 'PJ');
$ffi->attach( proj_create_crs_to_crs => [qw( PJ_CONTEXT string string PJ_AREA )] => 'PJ');
$ffi->attach( proj_create_crs_to_crs_from_pj => [qw( PJ_CONTEXT PJ PJ PJ_AREA string_array )] => 'PJ', sub{
	$_[0]->( @_[1..4], $_[5] || [] );  # StringArray won't accept NULL
});
$ffi->attach( proj_normalize_for_visualization => ['PJ_CONTEXT', 'PJ'] => 'PJ');
$ffi->attach( proj_destroy => ['PJ'] => 'void');


# Apply transformation to observation - in forward or inverse direction
FFI::C->enum('PJ_DIRECTION', [
	[PJ_FWD   =>  1],  # Forward
	[PJ_IDENT =>  0],  # Do nothing
	[PJ_INV   => -1],  # Inverse
]);


$ffi->attach( proj_trans => ['PJ', 'PJ_DIRECTION', 'PJ_COORD'] => 'PJ_COORD');

# non-standard method (now discouraged; originally used by Perl cs2cs)
# (expects and returns a single point as array ref)
$ffi->attach( [proj_trans => '_trans'] => ['PJ', 'PJ_DIRECTION', 'PJ_COORD'] => 'PJ_COORD', sub {
	my ($sub, $pj, $dir, $coord) = @_;
	$sub->( $pj, $dir, proj_coord($coord->[0] // 0, $coord->[1] // 0, $coord->[2] // 0, $coord->[3] // 0) )->v;
});


# Initializers
$ffi->attach( proj_coord => [qw( double double double double )] => 'PJ_COORD');

# Set or read error level
$ffi->attach( proj_context_errno => ['PJ_CONTEXT'] => 'int');
$ffi->attach( proj_errno_string => ['int'] => 'string');  # deprecated. use proj_context_errno_string()
eval { $ffi->attach( proj_context_errno_string => ['PJ_CONTEXT', 'int'] => 'string'); 1 }
	or do { *proj_context_errno_string = sub { proj_errno_string($_[1]); } };

$ffi->attach( proj_log_level => ['PJ_CONTEXT', 'PJ_LOG_LEVEL'] => 'PJ_LOG_LEVEL');

# Info functions - get information about various PROJ.4 entities
$ffi->attach( proj_info => [] => 'PJ_INFO');

$ffi->attach( proj_cleanup => [] => 'void');

1;

__END__