File Coverage

blib/lib/Data/Dimensions.pm

Criterion	Covered	Total	%
statement	129	189	68.2
branch	28	44	63.6
condition	7	19	36.8
subroutine	29	52	55.7
pod	2	17	11.7
total	195	321	60.7

package Data::Dimensions;

use Data::Dimensions::Map;
use Data::Dimensions::SickTie;
use strict;
use vars qw($VERSION @ISA @HANDLER);
@ISA = qw();
$VERSION = '0.05';

# use me baby
sub import {
    my ($class, @stuff) = @_;
    foreach (@stuff) {
	if ($_ eq 'extended') {
	    push_handler(\&Data::Dimensions::Map::parse_other);
	}
	if ($_ eq '&units') {
	    my ($pack) = caller;
	    {
		no strict 'refs';
		*{$pack . '::units'} = \&units;
	    }
	}
    }
}

# These are the vaguely public methods
sub set :lvalue {
    my $self = shift;
    if (@_) {
	$self->natural(@_);
	return $self;
    }
    # I can't stop using this as it exists now
    my $foo;
    tie $foo, 'Data::Dimensions::SickTie', $self, @_;
    $foo;
}

# For, er, symmetry, yes.
sub get {
    my $self = shift;
    return $self->natural;
}

sub new {
    my ($class, $units, $value) = @_;
    $class = ref($class) || $class;
    my $self = {};
    @{$self}{qw(units scale)} = basicate_units($units);
    $self->{base} = $value * $self->{scale}
      if defined ($value);
    return bless $self, $class;
}

sub units {
    Data::Dimensions->new(@_);
}

#### tie() now works? for perl 5.14 so
sub TIESCALAR {
  if ($] < 5.014) {
    croak("Cannot use tie with Data::Dimensions in Perl < 5.14.0, use set \$foo = ... instead");
  }
  my $class = shift;

  my $units = shift || {};
  my $val = shift || undef; # because
  $class->new($units, $val);
}
sub FETCH {
  return $_[0];
}
sub STORE {
  my ($self, $val) = @_;
  if (!ref($val) || !UNIVERSAL::isa($val, 'Data::Dimensions')) { # make a new me from a 'value'
    $self->natural($val);
  }
  else {
    $self->_moan("Storing value with incorrect units")
      unless $self->same_units($val);
    $self->base($val->base);
  }
}



#####  Not so public methods
sub natural {
    my $self = shift;
    if (@_) {
	$self->{base} = $_[0] * $self->{scale};
    }
    else {
	return ($self->{base} / $self->{scale});
    }
}

sub base {
    my $self = shift;
    if (@_) {
	$self->{base} = $_[0];
    }
    else {
	return $self->{base};
    }
}

sub same_units {
    my ($self, $other) = @_;
    my ($ou, $tu) = ($self->{units}, $other->{units});
    my %temp = (%$ou, %$tu);

    {
	local $^W = 0; # look Ma! No warnings.
	foreach (keys %temp) {
	    return 0 if $ou->{$_} != $tu->{$_};
	}
    }
    return 1;
}

sub no_units {
    my $self = shift;
    my $ou = $self->{units};
    foreach (keys %{$ou}) {
	return 0 if $ou->{$_};
    }
    return 1;
}

## debug and death
sub _dump {
    my $self = shift;
    print overload::StrVal($self);
    print " base: ", $self->{base}, " scale:", $self->{scale}, "\n";
    foreach (keys %{$self->{units}}) {
	print " $_ => ", $self->{units}->{$_}, "\n";
    }
}

sub _moan {
    my $i = 0;
    while ((caller($i))[0] =~ /Data.*Dimensions/) {
	$i++;
    }
    my ($pack, $file, $line) = caller($i);
    die($_[1] ." at $file line $line\n");
}

#####  Overloading gubbins
# We use _guard to make sure both arguments are Data::Dimensions objects
# and to reverse arguments before they get any further
# as this simplifies code in the overloading routines

sub _guard {
    my ($one, $two, $r) = @_;
    if ($r) {
	$two = $one->new({}, $two);
	($one, $two) = ($two, $one);
    }
    elsif (!(ref($two) && UNIVERSAL::isa($two, 'Data::Dimensions'))) {
	$two = $one->new({}, $two);
    }
    return ($one, $two);
}

use overload
# these must be between objects with the same units
    '+' => sub {u_arith(sub {$_[0] + $_[1]}, @_)},
    '-' => sub {u_arith(sub {$_[0] - $_[1]}, @_)},
    '%' => sub {u_arith(sub {$_[0] % $_[1]}, @_)},
    '&' => sub {u_arith(sub {$_[0] & $_[1]}, @_)},
    '|' => sub {u_arith(sub {$_[0] | $_[1]}, @_)},
    '^' => sub {u_arith(sub {$_[0] ^ $_[1]}, @_)},
    '<=>' => sub {u_comp(sub {$_[0] <=> $_[1]}, @_)},
    'cmp' => sub {u_comp(sub {$_[0] cmp $_[1]}, @_)},

# these can propogate their units
    '/' => sub {u_div(sub {$_[0] / $_[1]}, &_guard)},
    '*' => sub {u_mul(sub {$_[0] * $_[1]}, &_guard)},

# these need to be careful about basic/natural units
    '++' => sub {$_[0]->natural($_[0]->natural + 1), shift},
    '--' => sub {$_[0]->natural($_[0]->natural - 1), shift},

# These need (some) args with NO units, and need natural units
    '**' => sub {u_exp(&_guard)},
    'cos' => sub {u_nounit(sub {cos $_[0]}, $_[0])},
    'sin' => sub {u_nounit(sub {sin $_[0]}, $_[0])},
    'exp' => sub {u_nounit(sub {exp $_[0]}, $_[0])},
    'log' => sub {u_nounit(sub {log $_[0]}, $_[0])},
    'sqrt' => sub {u_exp(sub {$_[0] ** $_[1]}, _guard($_[0], 0.5, 0))},

# These output, so need to use natural units
    '0+' => sub {$_[0]->natural},
    '""' => sub {$_[0]->natural},
    'bool' => sub {$_[0]->{base}},

    '=' => \&clone;
;
sub clone {
    my $new = $_[0]->new($_[0]->{units});
    $new->{scale} = $_[0]->{scale};
    $new->{base} = $_[0]->{base};
    return $new;
}

# Both args must have same units, return has same units
# try to keep result scaled as $one
sub u_arith {
    my ($op, $one, $two, $r) = @_;
    my $result = $one->new($one->{units});
    $result->{scale} = $one->{scale};
    if ($r) {
	$result->natural(&$op, $two, $one->natural);
    }
    elsif (!(ref($two) && UNIVERSAL::isa($two, 'Data::Dimensions'))) {
      $result->natural(&$op($one->natural, $two));
    }
    else {
	$one->_moan("Mixing different types in arithmetic operation")
	    unless ($one->same_units($two));
	$result->base(&$op($one->base, $two->base));
    }
    return $result;
}

# Must have same units on each side, compare in base units
sub u_comp {
    my ($op, $one, $two, $r) = @_;
    if ($r) {
	return &$op($two, $one->natural);
    }
    elsif (!(ref($two) && UNIVERSAL::isa($two, 'Data::Dimensions'))) {
	return &$op($one->natural, $two);
    }
    else {
	$one->_moan("Mixing different types in comparison operation")
	    unless $one->same_units($two);
	return &$op($one->{base}, $two->{base});
    }
}

# Can have different units, must propogate units and scaling correctly
sub u_div {
    my ($op, $one, $two) = @_;
    my $result = $one->new($one->{units});
    my ($ru, $tu) = ($result->{units}, $two->{units});
    foreach (keys %$tu) {
	$ru->{$_} -= $tu->{$_};
    }
    $result->{scale} = $one->{scale} / $two->{scale};
    $result->{base} = &$op($one->{base}, $two->{base});
    return $result;
}

sub u_mul {
    my ($op, $one, $two) = @_;
    my $result = $one->new($one->{units});
    my ($ru, $tu) = ($result->{units}, $two->{units});
    foreach (keys %$tu) {
	$ru->{$_} += $tu->{$_};
    }
    $result->{scale} = $one->{scale} * $two->{scale};
    $result->{base} = &$op($one->{base}, $two->{base});
    return $result;
}

# a**b, b must not have units, a can and these must propogate
sub u_exp {
    my ($one, $two) = @_;
    $one->_moan("Cannot raise to exponent with units")
	unless $two->no_units;
    my $result = $one->new($one->{units});
    my $ru = $result->{units};
    my $expn = $two->natural;
    foreach (keys %$ru) {
	$ru->{$_} *= $expn;
    }
    $result->{scale} = $one->{scale} ** $expn;
    $result->natural($one->natural ** $expn);
    return $result;
}

# for single arg functions, like cos()
sub u_nounit {
    my ($op, $one) = @_;
    $one->_moan("Value must have no units")
	unless $one->no_units;
    return &$op($one->natural);
}

#####  Stuff to cope with turning natural units into basic units
#   See also Data::Dimensions::Map
BEGIN {
    @HANDLER =( \&Data::Dimensions::Map::parse_SI);
}

sub push_handler { # ok, ok, it shifts... you try foreach backwards
    my $handler = shift;
    $handler = UNIVERSAL::isa($handler, 'CODE') ? $handler : shift;
    unshift @HANDLER, $handler;
}

# Charge through appropriate handlers
sub basicate_units {
    my ($hr) = @_;
    my $scale = 1;
    # prefixes
    ($hr, $scale) = Data::Dimensions::Map::parse_prefix($hr, $scale);
    # everything else
    foreach (@HANDLER) {
	($hr, $scale) = &$_($hr, $scale);
    }
    return ($hr, $scale);
}

1;
__END__