File Coverage

lib/Geo/LibProj/cs2cs.pm

Criterion	Covered	Total	%
statement	142	142	100.0
branch	87	90	96.6
condition	33	34	97.0
subroutine	20	20	100.0
pod	4	4	100.0
total	286	290	98.6

use 5.014;
use strict;
use warnings;

package Geo::LibProj::cs2cs;
# ABSTRACT: IPC interface to PROJ cs2cs
$Geo::LibProj::cs2cs::VERSION = '1.03';

use Carp qw(carp croak);
use File::Basename qw(basename);
use File::Spec;
use Scalar::Util 1.10 qw(looks_like_number);

use IPC::Run3 qw(run3);


our $CMD = 'cs2cs';
our @PATH = ();
BEGIN {
	# optional modules
	eval "require Alien::proj" or eval "require Alien::Proj4";
}
eval { unshift @PATH, File::Spec->catdir(Alien::proj->dist_dir, 'bin') };
eval { push @PATH, undef, File::Spec->catdir(Alien::Proj4->dist_dir, 'bin') };


# default stringification formats for cs2cs stdin and stdout
our $FORMAT_IN  = '%.15g';
our $FORMAT_OUT = '%.12g';

our %PARAMS = (
	-f => $FORMAT_OUT,
);


sub new {
	my $class = shift;

	my ($source_crs, $target_crs, $user_params);
	if ( ref($_[0]) eq 'HASH' ) {
		($user_params, $source_crs, $target_crs) = @_;
	}
	else {
		($source_crs, $target_crs, $user_params) = @_;
	}

	my $self = bless {}, $class;

	my $params = { %PARAMS, defined $user_params ? %$user_params : () };
	$self->_special_params($params);
	$self->{format_in} = $FORMAT_IN;

	# assemble cs2cs call line
	for my $key (keys %$params) {
		delete $params->{$key} unless defined $params->{$key};
	}
	my @source_crs = split m/ /, $source_crs // 'undef';
	my @target_crs = split m/ /, $target_crs // 'undef';
	$self->{cmd} = $self->_cmd();
	$self->{call} = [$self->{cmd}, %$params, @source_crs, '+to', @target_crs, '-'];

	$self->_ffi_init($source_crs, $target_crs, $params);

	return $self;
}


sub _special_params {
	my ($self, $params) = @_;

	# support -d even for older cs2cs versions
	if (defined $params->{-d} && defined $params->{-f}) {
		$params->{-f} = '%.' . (0 + $params->{-d}) . 'f';
		delete $params->{-d};
	}

	croak "-E is unsupported" if defined $params->{'-E'};
	croak "-t is unsupported" if defined $params->{'-t'};
	croak "-v is unsupported" if defined $params->{'-v'};

	# -w3 must be supplied as a single parameter to cs2cs
	if (defined $params->{-w}) {
		$params->{"-w$params->{-w}"} = '';
		delete $params->{-w};
	}
	if (defined $params->{-W}) {
		$params->{"-W$params->{-W}"} = '';
		delete $params->{-W};
	}

	$self->{ffi} = $INC{'Geo/LibProj/FFI.pm'}
	               && ( $params->{XS} || ! defined $params->{XS} );
	$self->{ffi_warn} = $params->{XS};
	delete $params->{XS};
}


sub _cmd {
	# try to find the cs2cs binary
	foreach my $path (@PATH) {
		if (defined $path) {
			my $cmd = File::Spec->catfile($path, $CMD);
			return $cmd if -e $cmd;
		}
		else {
			# when the @PATH element is undefined, try the env PATH
			eval { run3 [$CMD, '-lp'], \undef, \undef, \undef };
			return $CMD if ! $@ && $? == 0;
		}
	}

	# no luck; let's just hope it'll be on the PATH somewhere
	return $CMD;
}


sub _ffi_init {
	my ($self, $source_crs, $target_crs, $params) = @_;

	carp "Geo::LibProj::FFI is not loaded; falling back to IPC mode" if $self->{ffi_warn} && ! $self->{ffi};
	return unless $self->{ffi};

	my @params = grep {
		$_ eq '-f'
		? defined $params->{$_} && $params->{$_} ne $FORMAT_OUT
		: defined $params->{$_}
	} keys %$params;
	carp "cs2cs control parameters are unsupported in XS mode; falling back to IPC mode" if $self->{ffi_warn} && @params;
	return $self->{ffi} = 0 if @params;

	my $ctx = $self->{ffi_ctx} = Geo::LibProj::FFI::proj_context_create();
	carp "proj_context_create() failed; falling back to IPC mode" if $self->{ffi_warn} && ! $ctx;
	return $self->{ffi} = 0 if ! $ctx;

	Geo::LibProj::FFI::proj_context_use_proj4_init_rules($ctx, 1);

	my $pj = $self->{ffi_pj} = Geo::LibProj::FFI::proj_create_crs_to_crs(
			$ctx, $source_crs, $target_crs, undef );
	carp "proj_create_crs_to_crs() failed; falling back to IPC mode" if $self->{ffi_warn} && ! $pj;
	return $self->{ffi} = 0 if ! $pj;
}


sub DESTROY {
	my ($self) = @_;

	Geo::LibProj::FFI::proj_destroy($self->{ffi_pj}) if $self->{ffi_pj};
	Geo::LibProj::FFI::proj_context_destroy($self->{ffi_ctx}) if $self->{ffi_ctx};
	$self->{ffi_pj} = $self->{ffi_ctx} = 0;
}


sub _ipc_error_check {
	my ($self, $eval_err, $os_err, $code, $stderr) = @_;

	my $cmd = $CMD;
	if (ref $self) {
		$self->{stderr} = $stderr;
		$self->{status} = $code >> 8;
	}

	$stderr =~ s/^(.*\S)\s*\z/: $1/s if length $stderr;
	croak "`$cmd` failed to execute: $os_err" if $code == -1;
	croak "`$cmd` died with signal " . ($code & 0x7f) . $stderr if $code & 0x7f;
	croak "`$cmd` exited with status " . ($code >> 8) . $stderr if $code;
	croak $eval_err =~ s/\s+\z//r if $eval_err;
}


sub _format {
	my ($self, $value) = @_;

	return sprintf $self->{format_in}, $value if looks_like_number $value;
	return $value;
}


sub transform {
	my ($self, @source_points) = @_;

	return $self->_ffi_transform(@source_points) if $self->{ffi};

	my @in = ();
	foreach my $i (0 .. $#source_points) {
		my $p = $source_points[$i];
		push @in,   $self->_format($p->[0] || 0) . " "
		          . $self->_format($p->[1] || 0) . " "
		          . $self->_format($p->[2] || 0) . " $i";
	}
	my $in = join "\n", @in;

	my @out = ();
	my $err = '';
	eval {
		local $/ = "\n";
		run3 $self->{call}, \$in, \@out, \$err;
	};
	$self->_ipc_error_check($@, $!, $?, $err);

	my @target_points = ();
	foreach my $line (@out) {
		next unless $line =~ m{\s(\d+)\s*$}xa;
		my $aux = $source_points[$1]->[3];
		next unless $line =~ m{^\s* (\S+) \s+ (\S+) \s+ (\S+) \s}xa;
		my @p = defined $aux ? ($1, $2, $3, $aux) : ($1, $2, $3);

		foreach my $j (0..2) {
			$p[$j] = 0 + $p[$j] if looks_like_number $p[$j];
		}

		push @target_points, \@p;
	}

	if ( (my $s = @source_points) != (my $t = @target_points) ) {
		croak "Source/target point count doesn't match ($s/$t): Assertion failed";
	}

	return @target_points if wantarray;
	return $target_points[0] if @target_points < 2;
	croak "transform() with list argument prohibited in scalar context";
}


sub _ffi_transform {
	my ($self, @source_points) = @_;

	my @target_points = map {
		my $p = Geo::LibProj::FFI::_trans( $self->{ffi_pj}, 1, [$_->[0], $_->[1], $_->[2], 'Inf'] );
		$p->[3] = $_->[3];
		delete $p->[3] unless defined $p->[3];
		$p;
	} @source_points;

	return @target_points if wantarray;
	return $target_points[0] if @target_points < 2;
	croak "transform() with list argument prohibited in scalar context";
}


sub version {
	my ($self) = @_;

	my $ffi = ref $self ? $self->{ffi} : $INC{'Geo/LibProj/FFI.pm'};
	return Geo::LibProj::FFI::proj_info()->version if $ffi;

	my $out = '';
	eval {
		run3 [ $self->_cmd ], \undef, \$out, \$out;
	};
	$self->_ipc_error_check($@, $!, $?, '');

	return $1 if $out =~ m/\b(\d+\.\d+(?:\.\d\w*)?)\b/;
	return $out;
}


sub xs { shift->{ffi} }


1;

__END__