File Coverage

blib/lib/Physics/Unit/Scalar.pm

Criterion	Covered	Total	%
statement	221	282	78.3
branch	68	134	50.7
condition	36	81	44.4
subroutine	42	49	85.7
pod	13	18	72.2
total	380	564	67.3

package Physics::Unit::Scalar;

use strict;
use warnings;
use Carp;
use base qw(Exporter);
use vars qw( $VERSION @EXPORT_OK %EXPORT_TAGS $debug);

$VERSION = '0.60';
$VERSION = eval $VERSION;

@EXPORT_OK = qw( ScalarFactory GetScalar );
%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);

use Physics::Unit ':ALL';


InitSubtypes();

sub new {
    my $proto = shift;
    print "Scalar::new:  proto is $proto.\n" if $debug;
    my $class;
    my $self = {};

    if (ref $proto) {
        # Copy constructor
        $class = ref $proto;
        $self->{$_} = $$proto{$_} for keys %$proto;
    }
    else {
        # Construct from a definition string
        # Get the definition string, and remove whitespace
        my $def = shift;
        print "def is '$def'.\n" if $debug;
        if (defined $def) {
            $def =~ s/^\s*(.*?)\s*$/$1/;
        }

        $class = $proto;

        # Convert the argument into a unit object
        if ($class eq 'Physics::Unit::Scalar') {
            # Build a generic Physics::Unit::Scalar object

            return ScalarFactory($def);

            #my $u = Physics::Unit->new($def);
            #$self->{value} = $u->factor;
            #$u->factor(1);
            #$self->{MyUnit} = $self->{default_unit} = $u;
        }
        else {
            # The user specified the type of Scalar explicitly
            my $mu = $self->{MyUnit} = $self->{default_unit} =
                GetMyUnit($class);

            # If no definition string was given, then set the value to
            # one.

            if (!defined $def || $def eq '') {
                $self->{value} = 1;
            }

            # If the definition consists of just a number, then we'll use
            # the default unit

            elsif ($def =~ /^$Physics::Unit::number_re$/io) {
                $self->{value} = $def + 0;  # convert to number
            }

            else {
                my $u = GetUnit($def);

                croak 'Unit definition string is of incorrect type'
                    if 'Physics::Unit::' . $u->type ne $class;

                $self->{value} = $u->convert($mu);
            }
        }
    }

    bless $self, $class;
}

sub ScalarFactory {
    my $self = {
        value  => 1,
        MyUnit => Physics::Unit->new(shift),
    };

    # Call the mystery ScalarResolve() function.
    return ScalarResolve($self);
}

sub default_unit {
    my $proto = shift;
    if (ref $proto) {
        return $proto->{default_unit};
    }
    else {
        return GetDefaultUnit($proto);
    }
}

sub ToString {
    my $self = shift;
    return $self->value .' '. $self->MyUnit->ToString unless @_;
    my $u = GetUnit(shift);
    my $v = $self->value * $self->MyUnit->convert($u);
    return $v .' '. $u->ToString;
}

sub convert {
    my $self = shift;

    my $u = GetUnit(shift);

    croak 'convert called with invalid parameters'
        if !ref $self || !ref $u;

    return $self->value * $self->MyUnit->convert($u);
}

sub value {
    my $self = shift;
    $self->{value} = shift if @_;
    return $self->{value};
}

sub add {
    my $self = shift;

    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::add'
        if !ref $self || !ref $other;
    carp "Scalar types don't match in add()"
        if ref $self ne ref $other;

    $self->{value} += $other->{value};

    return $self;
}

sub neg {
    my $self = shift;
    croak 'Invalid arguments to Physics::Unit::Scalar::neg'
        if !ref $self;

    $self->{value} = - $self->{value};
}

sub subtract {
    my $self = shift;

    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::subtract'
        if !(ref $self) || !(ref $other);
    carp "Scalar types don't match in subtract()"
        if ref $self ne ref $other;

    $self->{value} -= $other->{value};

    return $self;
}

sub times {
    my $self = shift;
    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::times'
        if !ref $self || !ref $other;

    my $value = $self->{value} * $other->{value};

    my $mu = $self->{MyUnit}->copy;

    $mu->times($other->{MyUnit});

    my $newscalar = {
        value  => $value,
        MyUnit => $mu,
    };

    return ScalarResolve($newscalar);
}

sub recip {
    my $self = shift;
    croak 'Invalid argument to Physics::Unit::Scalar::recip'
        unless ref $self;

    croak 'Attempt to take reciprocal of a zero Scalar'
        unless $self->{value};

    my $mu = $self->{MyUnit}->copy;

    my $newscalar = {
        value  => 1 / $self->{value},
        MyUnit => $mu->recip,
    };

    return ScalarResolve($newscalar);
}

sub divide {
    my $self = shift;

    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::times'
        if !ref $self || !ref $other;

    my $arg = $other->recip;

    return $self->times($arg);
}

sub GetScalar {
    my $n = shift;
    if (ref $n) {
        return $n;
    }
    else {
        return ScalarFactory($n);
    }
}

sub InitSubtypes {
    for my $type (ListTypes()) {
        print "Creating class $type\n" if $debug;

        my $prototype = GetTypeUnit($type);
        my $type_unit_name = $prototype->name || $prototype->def;
        {
            no strict 'refs';
            no warnings 'once';
            my $package = 'Physics::Unit::' . $type;
            @{$package . '::ISA'} = qw(Physics::Unit::Scalar);
            ${$package . '::DefaultUnit'} = ${$package . '::MyUnit'} =
                GetUnit( $type_unit_name );
        }
    }
}

sub MyUnit {
    my $proto = shift;
    if (ref ($proto)) {
        return $proto->{MyUnit};
    }
    else {
        return GetMyUnit($proto);
    }
}

sub GetMyUnit {
    my $class = shift;
    no strict 'refs';
    return ${$class . '::MyUnit'};
}

sub GetDefaultUnit {
    my $class = shift;
    no strict 'refs';
    return ${$class . '::DefaultUnit'};
}

sub ScalarResolve {
    my $self = shift;

    my $mu = $self->{MyUnit};
    my $type = $mu->type;

    if ($type) {
        $type = 'dimensionless' if $type eq 'prefix';
        $type = 'Physics::Unit::' . $type;

        my $newunit = GetMyUnit($type);
        $self->{value} *= $mu->convert($newunit);
        $self->{MyUnit} = $newunit;
        $self->{default_unit} = $newunit;
    }
    else {
        $type = "Physics::Unit::Scalar";

        $self->{value} *= $mu->factor;
        $mu->factor(1);
        $self->{default_unit} = $mu;
    }

    bless $self, $type;
}

######### Overloading ######################
# Doesn't use the existing methods but
# defines new ones, so as not to interfere
# with any existing functionality.
############################################

our $format_string; # can be set to provide a
# parameter for sprintf() in the overloaded
# ToString function.

sub _overload_ToString {
    my $self = shift;

    return sprintf($format_string, $self->value) .' '. $self->MyUnit->ToString
        if defined $format_string;

    return $self->value .' '. $self->MyUnit->ToString;
}

# regarding string comparators, I think there is an
# argument that the numerical comparators (<=>) should work
# solely on the numeric component, and the string
# comparators (cmp) could work on the dimensions and their
# degree. For example, "GetScalar('1 m^2') lt GetScalar('1 m^3')"
# would be true. This would allow the user some flexibility
# in sorting. I've not done it because it would probably
# require a lot of time discussing and implementing to
# get right.
sub _overload_eq {
    my $self = shift;
    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_eq'
        if !ref $self || !ref $other;

    return $self->_overload_ToString() eq $other->_overload_ToString();
}

sub _overload_ne {
    my $self = shift;
    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_ne'
        if !ref $self || !ref $other;

    return $self->_overload_ToString() ne $other->_overload_ToString();
}

# There appears to be a bug in ScalarResolve()
# if $mu->type comes back with an arrayref,
# e.g. in the case of ambiguous type for a derived
# unit such as ['Energy', 'Torque'], then it crashes,
# as it doesn't seem to be able to handle that.
# _ScalarResolve() tries to fix this by checking
# global variable @type_context to see if the user
# has set a preferred type to use (a hacky solution,
# admittedly); or if not, it just takes the first
# entry in the type arrayref so as not to crash.
our @type_context = ();

# See if the user has set a preferred unit type for
# the calculations they are performing.
sub _DisambiguateType {
    my $ar = shift;

    if ( scalar(@type_context) ) {
        foreach my $type (@{$ar}) {
            foreach my $preferred (@type_context) {
                if ( $type eq $preferred ) {
                    return $type;
                }
            }
        }
    }

    return $ar->[0];
}

sub _ScalarResolve {
    my $self = shift;

    my $mu = $self->{MyUnit};
    my $type = $mu->type;

    if ($type) {
        # the following line is the only change to the original
        $type = _DisambiguateType($type) if ref($type) eq 'ARRAY';
        $type = 'dimensionless' if $type eq 'prefix';
        $type = 'Physics::Unit::' . $type;

        my $newunit = GetMyUnit($type);
        $self->{value} *= $mu->convert($newunit);
        $self->{MyUnit} = $newunit;
        $self->{default_unit} = $newunit;
    }
    else {
        $type = "Physics::Unit::Scalar";

        $self->{value} *= $mu->factor;
        $mu->factor(1);
        $self->{default_unit} = $mu;
    }

    bless $self, $type;
}

sub _overload_add {
    my $self = shift;
    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_add'
        if !ref $self || !ref $other;

    # overloading should return a new object
    my $n = $self->new();

    # be a bit strict here about what can be added to what else
    if (    (ref($self) eq ref($other)) ||
            (ref($self) eq 'Physics::Unit::Dimensionless') ||
            (ref($other) eq 'Physics::Unit::Dimensionless') ) {

        $n->{value} += $other->{value};
    }
    else {
        carp 'Cannot add a ' . ref($self) . ' to a ' . ref($other);
    }

    return $n;
}

sub _overload_subtract {
    my $self = shift;
    my $other = GetScalar(shift);
    my $swapped = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_subtract'
        if !ref $self || !ref $other;

    my $n = $self->new();

    if (    (ref($self) eq ref($other)) ||
            (ref($self) eq 'Physics::Unit::Dimensionless') ||
            (ref($other) eq 'Physics::Unit::Dimensionless') ) {

        if ( defined($swapped) and ($swapped == 1) ) {
            $n->{value} = $other->{value} - $n->{value};
        }
        else {
            $n->{value} -= $other->{value};
        }
    }
    else {

        if ( defined($swapped) and ($swapped == 1) ) {
            carp 'Cannot subtract a ' . ref($self) . ' from a ' . ref($other);
        }
        else {
            carp 'Cannot subtract a ' . ref($other) . ' from a ' . ref($self);
        }
    }

    return $n;
}

sub _overload_times {
    my $self = shift;
    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_times'
        if !ref $self || !ref $other;

    my $value = $self->{value} * $other->{value};

    my $mu = $self->{MyUnit}->copy;

    $mu->times($other->{MyUnit});

    my $newscalar = {
        value  => $value,
        MyUnit => $mu,
    };

    return _ScalarResolve($newscalar);
}

sub _overload_divide {
    my $self = shift;
    my $other = GetScalar(shift);
    my $swapped = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_divide'
        if !ref $self || !ref $other;

    if ( defined($swapped) and ($swapped == 1) ) {
        my $arg = $self->recip;
        return $other->times($arg);
    }
    else {
        my $arg = $other->recip;
        return $self->times($arg);
    }
}

sub _overload_power {
    my $self = shift;
    my $other = GetScalar(shift);

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_power'
        if !ref $self || !ref $other;

    croak "Physics::Unit::Scalar::_overload_power: can only raise to dimensionless powers (got '$other')"
        if ref($other) ne 'Physics::Unit::Dimensionless';

    my $p = $other->value();

    croak "Physics::Unit::Scalar::_overload_power: can only raise to integer powers currently (got '$p')"
        unless $p == int($p);

    my $n = $self->new();

    # be explicit about different scenarios
    if ( $p < -1 ) {
        $p = abs($p)-1;
        $n = $n->times($self) while $p--;
        return $n->recip;
    }
    elsif ( $p == -1 ) {
        return $n->recip;
    }
    elsif ( $p == 0 ) {
        return GetScalar(1);
    }
    elsif ( $p == 1 ) {
        return $n;
    }
    else {
        $p--;
        $n = $n->times($self) while $p--;
        return $n;
    }

}

sub _overload_sin {
    my $self = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_sin'
        if !ref $self;

    carp "Warning: Arguments to sin() would be without dimension, traditionally. (got '$self')"
        unless ref($self) eq 'Physics::Unit::Dimensionless';

    return sin($self->{value});
}

sub _overload_cos {
    my $self = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_cos'
        if !ref $self;

    carp "Warning: Arguments to cos() would be without dimension, traditionally. (got '$self')"
        unless ref($self) eq 'Physics::Unit::Dimensionless';

    return cos($self->{value});
}

sub _overload_atan2 {
    my $self = shift;
    my $other = GetScalar(shift);
    my $swapped = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_atan2'
        if !ref $self || !ref $other;

    my $n;

    if (    (ref($self) eq ref($other)) ||
            (ref($self) eq 'Physics::Unit::Dimensionless') ||
            (ref($other) eq 'Physics::Unit::Dimensionless') ) {

        my $atan2v = $swapped ? atan2($other->{value}, $self->{value}) : atan2($self->{value}, $other->{value});
        $n = GetScalar("$atan2v radians") if defined $atan2v;
    }
    else {
        croak 'Cannot perform atan2 of ' . ref($self) . ' with ' . ref($other);
    }

    return $n;
}

sub _overload_exp {
    my $self = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_exp'
        if !ref $self;

    carp "Warning: Arguments to exp() would be without dimension, traditionally. (got '$self')"
        unless ref($self) eq 'Physics::Unit::Dimensionless';

    return exp($self->{value});
}

sub _overload_log {
    my $self = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_log'
        if !ref $self;

    carp "Warning: Arguments to log() would be without dimension, traditionally. (got '$self')"
        unless ref($self) eq 'Physics::Unit::Dimensionless';

    return log($self->{value});
}

sub _overload_int {
    my $self = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_int'
        if !ref $self;

    my $n = $self->new();

    $n->{value} = int($n->{value});

    return $n;
}

sub _overload_abs {
    my $self = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_abs'
        if !ref $self;

    my $n = $self->new();

    $n->{value} = abs($n->{value});

    return $n;
}

# by overloading <=>, we will get the other comparison operators too
sub _overload_spaceship {
    my $self = shift;
    my $other = GetScalar(shift);
    my $swapped = shift;

    croak 'Invalid arguments to Physics::Unit::Scalar::_overload_spaceship'
        if !ref $self || !ref $other;

    if (    (ref($self) eq ref($other)) ||
            (ref($self) eq 'Physics::Unit::Dimensionless') ||
            (ref($other) eq 'Physics::Unit::Dimensionless') ) {

        return $swapped ? $other->{value} <=> $self->{value} : $self->{value} <=> $other->{value};
    }
    else {
        # perhaps being a bit strict here
        croak 'Cannot compare a ' . ref($self) . ' to a ' . ref($other);
    }
}

use overload
    "+"         =>      \&_overload_add,
    "-"         =>      \&_overload_subtract,
    "*"         =>      \&_overload_times,
    "/"         =>      \&_overload_divide,
    "**"        =>      \&_overload_power,
    "sin"       =>      \&_overload_sin,
    "cos"       =>      \&_overload_cos,
    "atan2"     =>      \&_overload_atan2,
    "exp"       =>      \&_overload_exp,
    "log"       =>      \&_overload_log,
    "int"       =>      \&_overload_int,
    "abs"       =>      \&_overload_abs,
    "<=>"       =>      \&_overload_spaceship,
    "eq"        =>      \&_overload_eq,
    "ne"        =>      \&_overload_ne,
    '""'        =>      \&_overload_ToString,
    "0+"        =>      sub { $_[0]->value() },
    "bool"      =>      sub { $_[0]->value() },
    ;

1;

__END__