view release on metacpan or  search on metacpan

lib/Module/Generic/DateTime.pm  view on Meta::CPAN

    undef( $self->{dt} ) if( defined( $self->{dt} ) );

    # For non-object context, we need to call cleanup to ensure there is no leftover
    my $class   = ref( $self );
    my $err_key = $class;
    my $repo    = Module::Generic::Global->new( 'local_tz' => $class, key => $err_key );
    $repo->cleanup;
    return( $self );
};

sub FREEZE
{
    my $self       = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class      = CORE::ref( $self );
    my $dt         = $self->{dt} || return;
    my $tz         = $dt->time_zone->name;
    my $fmt        = $dt->formatter;
    my $locale     = $dt->locale->code;
    my $hash = 
    {
        year        => $dt->year,
        month       => $dt->month,
        day         => $dt->day,
        hour        => $dt->hour,
        minute      => $dt->minute,
        second      => $dt->second,
        nanosecond  => $dt->nanosecond,
    };
    $hash->{time_zone} = $tz if( $tz );
    $hash->{formatter} = $fmt if( $fmt );
    $hash->{locale}    = $locale if( $locale );
    
    # Return an array reference rather than a list so this works with Sereal and CBOR
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    if( $serialiser eq 'Sereal' )
    {
        require Sereal::Encoder;
        require version;
    
        if( version->parse( Sereal::Encoder->VERSION ) <= version->parse( '4.023' ) )
        {
            CORE::return( [$class, $hash] );
        }
    }
    # But Storable want a list with the first element being the serialised element
    CORE::return( $class, $hash );
}

sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }

sub STORABLE_thaw_post_processing
{
    my $obj   = shift( @_ );
    my @keys  = %$obj;
    my $class = ref( $obj );
    my $hash  = {};
    @$hash{ @keys } = @$obj{ @keys };
    my $self = bless( $hash => $class );
    return( $self );
}

# NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments.
# NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze
sub THAW
{
    my( $self, undef, @args ) = @_;
    my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
    my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
    my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
    my @keys = qw( year month day hour minute second nanosecond time_zone formatter locale );
    my $opts = {};
    foreach my $prop ( @keys )
    {
        if( exists( $hash->{ $prop } ) &&
            defined( $hash->{ $prop } ) &&
            length( $hash->{ $prop } ) )
        {
            $opts->{ $prop } = $hash->{ $prop };
        }
    }

    local $@;
    my $dt = eval
    {
        require DateTime::Lite;
        DateTime::Lite->new( %$opts );
    };
    if( $@ )
    {
        require Module::Generic;
        warn( "Error thawing the DateTime::Lite object: $@\nParameters used were: ", Module::Generic->dump( $opts ) ) if( warnings::enabled() );
    }
    elsif( !defined( $dt ) )
    {
        warn( "Error thawing the DateTime::Lite object: ", DateTime::Lite->error, "\nParameters used were: ", Module::Generic->dump( $opts ) ) if( warnings::enabled() );
    }

    my $new;
    # Storable pattern requires to modify the object it created rather than returning a new one
    if( CORE::ref( $self ) )
    {
        $self->{dt} = $dt;
        $new = $self;
    }
    else
    {
        $new = CORE::bless( { dt => $dt } => $class );
    }
    CORE::return( $new );
}

sub TO_JSON
{
    my $self = CORE::shift( @_ );
    CORE::return( '' ) if( !$self->{dt} || !Scalar::Util::blessed( $self->{dt} ) );
    CORE::return( $self->{dt}->stringify );
}

# NOTE: package Module::Generic::DateTime::Interval
package Module::Generic::DateTime::Interval;
BEGIN
{
    use strict;
    use warnings;
    use parent qw( Module::Generic );
    use overload (
        '""'     => 'as_string',
        'bool'   => sub{1},
        '+'      => '__add_overload',
        '-'      => '__subtract_overload',
        '*'      => '__multiply_overload',
        '<=>'    => '__compare_overload',
        'cmp'    => '__compare_overload',
        fallback => 1,
    );
    use DateTime::Lite;
    use Scalar::Util ();
    use Wanted;
};

sub new
{
    my $this = shift( @_ );
    my $dur  = shift( @_ ) || return;
    return( bless( { interval => $dur->clone } => ( ref( $this ) || $this ) )->init( @_ ) );
}

# This class does not convert to an HASH
sub as_hash { return( $_[0] ); }

sub as_string
{
    my $self = shift( @_ );
    return( $self->{interval}->in_units( 'seconds' ) );
}

sub dump
{
    my $self = shift( @_ );
    my @info = $self->{interval}->in_units( qw( years months weeks days hours minutes seconds nanoseconds ) );
    my $tmpl = <<EOT;
Years ... %d
Months .. %d
Weeks ... %d
Days .... %d
Hours ... %d
Minutes . %d