view release on metacpan or  search on metacpan

lib/DateTime/Lite/Duration.pm  view on Meta::CPAN

}

sub is_limit_mode    { $_[0]->{end_of_month} eq 'limit'    ? 1 : 0 }
sub is_negative      { !$_[0]->_has_positive && $_[0]->_has_negative }
sub is_positive      { $_[0]->_has_positive  && !$_[0]->_has_negative }
sub is_preserve_mode { $_[0]->{end_of_month} eq 'preserve' ? 1 : 0 }
sub is_wrap_mode     { $_[0]->{end_of_month} eq 'wrap'     ? 1 : 0 }

sub is_zero
{
    my $self = shift( @_ );
    foreach my $unit ( @UNITS )
    {
        return(0) if( $self->{ $unit } != 0 );
    }
    return(1)
}

sub pass_error
{
    my $self = shift( @_ );
    my $pack = ref( $self ) || $self;
    my $opts = {};
    my( $err, $class, $code );
    no strict 'refs';
    if( scalar( @_ ) )
    {
        # Either an hash defining a new error and this will be passed along to error(); or
        # an hash with a single property: { class => 'Some::ExceptionClass' }
        if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' )
        {
            $opts = $_[0];
        }
        else
        {
            if( scalar( @_ ) > 1 && ref( $_[-1] ) eq 'HASH' )
            {
                $opts = pop( @_ );
            }
            $err = $_[0];
        }
    }
    $err = $opts->{error} if( !defined( $err ) && CORE::exists( $opts->{error} ) && defined( $opts->{error} ) && CORE::length( $opts->{error} ) );
    # We set $class only if the hash provided is a one-element hash and not an error-defining hash
    $class = $opts->{class} if( CORE::exists( $opts->{class} ) && defined( $opts->{class} ) && CORE::length( $opts->{class} ) );
    $code  = $opts->{code} if( CORE::exists( $opts->{code} ) && defined( $opts->{code} ) && CORE::length( $opts->{code} ) );

    # called with no argument, most likely from the same class to pass on an error 
    # set up earlier by another method; or
    # with an hash containing just one argument class => 'Some::ExceptionClass'
    if( !defined( $err ) && ( !scalar( @_ ) || defined( $class ) ) )
    {
        # $error is a previous erro robject
        my $error = ref( $self ) ? $self->{error} : length( ${ $pack . '::ERROR' } ) ? ${ $pack . '::ERROR' } : undef;
        if( !defined( $error ) )
        {
            warn( "No error object provided and no previous error set either! It seems the previous method call returned a simple undef" );
        }
        else
        {
            $err = ( defined( $class ) ? bless( $error => $class ) : $error );
            $err->code( $code ) if( defined( $code ) );
        }
    }
    elsif( defined( $err ) && 
           Scalar::Util::blessed( $err ) && 
           ( scalar( @_ ) == 1 || 
             ( scalar( @_ ) == 2 && defined( $class ) ) 
           ) )
    {
        $self->{error} = ${ $pack . '::ERROR' } = ( defined( $class ) ? bless( $err => $class ) : $err );
        $self->{error}->code( $code ) if( defined( $code ) && $self->{error}->can( 'code' ) );

        if( $self->{fatal} || ( defined( ${"${pack}\::FATAL_EXCEPTIONS"} ) && ${"${pack}\::FATAL_EXCEPTIONS"} ) )
        {
            die( $self->{error} );
        }
    }
    # If the error provided is not an object, we call error to create one
    else
    {
        return( $self->error( @_ ) );
    }

    if( want( 'OBJECT' ) )
    {
        rreturn( DateTime::Lite::NullObject->new );
    }
    return;
}

sub subtract
{
    my $self = shift( @_ );
    return( $self->add_duration( $self->_duration_from_args( @_ )->inverse ) );
}

sub subtract_duration { return( $_[0]->add_duration( $_[1]->inverse ) ) }

# NOTE: Sign predicates
sub _has_negative
{
    my $self = shift( @_ );
    foreach my $unit ( @UNITS )
    {
        return(1) if( $self->{ $unit } < 0 );
    }
    return(0)
}

sub _has_positive
{
    my $self = shift( @_ );
    foreach my $unit ( @UNITS )
    {
        return(1) if( $self->{ $unit } > 0 );
    }
    return(0)
}

# NOTE: Overloaded operators
sub _add_overload
{
    my( $self, $other, $reversed ) = @_;
    ( $self, $other ) = ( $other, $self ) if( $reversed );
    return( $self->clone->add_duration( $other ) );
}

sub _compare_overload
{
    my( $d1, $d2, $flip ) = @_;