DateTime::Incomplete - An incomplete datetime, like January 5

  my $dti = DateTime::Incomplete->new( year => 2003 );
  # 2003-xx-xx
  $dti->set( month => 12 );
  # 2003-12-xx
  $dt = $dti->to_datetime( base => DateTime->now );
  # 2003-12-19T16:54:33

package DateTime::Incomplete;

use strict;

use DateTime::Set 0.0901;
use DateTime::Event::Recurrence;
use Params::Validate qw( validate );

use vars qw( $VERSION );

my $UNDEF_CHAR;
my ( @FIELDS, %FIELD_LENGTH, @TIME_FIELDS, @FIELDS_SORTED );

BEGIN
{
    $VERSION = '0.06';

    $UNDEF_CHAR = 'x';

    @FIELDS = ( year => 0, month => 1, day => 1, 
                hour => 0, minute => 0, second => 0, nanosecond => 0 );
    %FIELD_LENGTH = ( 
                year => 4, month => 2, day => 2, 
                hour => 2, minute => 2, second => 2, nanosecond => 9,
                time_zone => 0, locale => 0 );
    @TIME_FIELDS = qw( hour minute second nanosecond );

    @FIELDS_SORTED = qw( year month day 
                hour minute second nanosecond 
                time_zone locale );

    # Generate named accessors

    for my $field ( @FIELDS_SORTED )
    {
	no strict 'refs';
	*{$field} = sub { $_[0]->_get($field) };
	*{"has_$field"} = sub { $_[0]->_has($field) };

        next if $field eq 'nanosecond';

	my $length = $FIELD_LENGTH{$field};

	next unless $length;

	*{"_$field"} = sub { defined $_[0]->$field() ?
			     sprintf( "%0.${length}d", $_[0]->$field() ) :
			     $UNDEF_CHAR x $length };
    }

    # Generate DateTime read-only functions

    for my $meth ( qw/
        epoch
        hires_epoch
        is_dst
        utc_rd_values
        utc_rd_as_seconds
        / )
    {
        no strict 'refs';
        *{$meth} = sub 
                   { 
                       # to_datetime() dies if there is no "base"
                       # we get 'undef' if this happens
                       eval { (shift)->to_datetime( @_ )->$meth() };
                   };
    }

    for my $meth ( qw/
        week week_year week_number week_of_month
        day_name day_abbr 
        day_of_week wday dow
        day_of_year doy
        quarter day_of_quarter doq
        weekday_of_month
        jd mjd
        / )
    {
	no strict 'refs';
	*{$meth} = sub { $_[0]->_datetime_method( $meth, 'year', 'month', 'day' ) };
    }

    for my $meth ( qw/
        is_leap_year ce_year era year_with_era
        / )
    {
	no strict 'refs';
	*{$meth} = sub { $_[0]->_datetime_method( $meth, 'year' ) };
    }

    for my $meth ( qw/
        month_name month_abbr
        / )
    {
	no strict 'refs';
	*{$meth} = sub { $_[0]->_datetime_method( $meth, 'month' ) };
    }

    for my $meth ( qw/
        hour_1 hour_12 hour_12_0
        / )
    {
	no strict 'refs';
	*{$meth} = sub { $_[0]->_datetime_method( $meth, 'hour' ) };
    }

    for my $meth ( qw/
        millisecond microsecond
        / )
    {
	no strict 'refs';
	*{$meth} = sub { $_[0]->_datetime_method( $meth, 'nanosecond' ) };
    }
}

*_nanosecond = \&_format_nanosecs;

*mon = \&month;
*day_of_month = \&day;
*mday = \&day;
*min = \&minute;
*sec = \&second;

# Internal sub to call "DateTime" methods
sub _datetime_method
{
    my ( $self, $method ) = ( shift, shift );
    my @fields = @_;   # list of required fields
    my $date;
    for ( @fields )
    {
        return undef unless ( $self->_has($_) )
    }
    my %param; 

    # if we don't need 'year', then we can safely set it to whatever.
    $param{year} = 1970 if ! @fields || $fields[0] ne 'year';

    $param{locale} = $self->locale if $self->has_locale;
    $param{time_zone} = $self->time_zone if $self->has_time_zone;
    $param{$_} = $self->$_() for @fields;
    $date = DateTime->new( %param );
    
    return $date->$method();
}

# DATETIME-LIKE METHODS

sub fractional_second {
    $_[0]->_datetime_method( 'fractional_second', 'second', 'nanosecond' );
}

sub offset {
    $_[0]->_datetime_method( 'offset' );
}
sub time_zone_short_name {
    $_[0]->_datetime_method( 'time_zone_short_name' );
}
sub time_zone_long_name  {
    $_[0]->_datetime_method( 'time_zone_long_name' );
}

sub _from_datetime
{
    my $class = shift;
    my $dt = shift;
    my %param;
    $param{$_} = $dt->$_() for @FIELDS_SORTED;
    return $class->new( %param );
}

sub last_day_of_month {
    my $self = shift;
    my %param = @_;
    my $result = $self->_from_datetime( DateTime->last_day_of_month( @_ ) );
    for ( @TIME_FIELDS ) {
        $result->set( $_, undef ) unless defined $param{$_};
    }
    return $result;
}

sub from_epoch {
    return (shift)->_from_datetime( DateTime->from_epoch( @_ ) );
}
sub now {
    return (shift)->_from_datetime( DateTime->now( @_ ) );
}
sub from_object {
    return (shift)->_from_datetime( DateTime->from_object( @_ ) );
}

sub from_day_of_year {
    my $self = shift;
    my %param = @_;
    my $result = $self->_from_datetime( DateTime->from_day_of_year( @_ ) );
    for ( @TIME_FIELDS ) {
        $result->set( $_, undef ) unless defined $param{$_};
    }
    return $result;
}

sub today
{
    my $class = shift;
    my $now = DateTime->now( @_ );
    my %param;
    my %fields = ( %FIELD_LENGTH );
    delete $fields{$_} for ( qw/ hour minute second nanosecond / );
    $param{$_} = $now->$_() for ( keys %fields );
    return $class->new( %param );
}

sub new 
{
    # parameter checking is done in "set" method.
    my $class = shift;
    my %param = @_;
    my $base = delete $param{base};
    die "base must be a datetime" if defined $base && 
                             ! UNIVERSAL::can( $base, 'utc_rd_values' );
    my $self = bless { 
        has => \%param,
    }, $class;
    $self->set_base( $base );
    $self->set( locale => $self->{has}{locale} ) if $self->{has}{locale};
    $self->set_time_zone( $self->{has}{time_zone} ) if $self->{has}{time_zone};
    return $self;
}

sub set_base 
{
    my $self = shift;
    $self->{base} = shift;
    if ( defined $self->{base} ) 
    {
        my ($key, $value);
        while (($key, $value) = each %{$self->{has}} ) {
            next unless defined $value;
            if ( $key eq 'time_zone' )
            {
                $self->{base}->set_time_zone( $value );
                next;
            }        
            $self->{base}->set( $key => $value );
        }
    }
}

sub base
{
    return undef unless defined $_[0]->{base};
    $_[0]->{base}->clone;
}

sub has_base
{
    return defined $_[0]->{base} ? 1 : 0;
}

sub set
{
    my $self = shift;
    my %p = @_;

    while ( my ( $k, $v ) = each %p )
    {
	if ( $k eq 'locale' )
	{
	    $self->_set_locale($v);
            next;
	}

	$self->{base}->set( $k => $v ) if $self->{base} && defined $v;

	$self->{has}{ $k } = $v;
    }
}

sub _get
{
    $_[0]->{has}{$_[1]};
}

sub _has
{
    defined $_[0]->{has}{$_[1]} ? 1 : 0;
}

sub has {  
    # returns true or false  
    my $self = shift;  
    foreach (@_) {  
        return 0 unless $self->_has( $_ )  
    }  
    return 1  
}  

sub has_date {
    $_[0]->has_year && $_[0]->has_month && $_[0]->has_day
}

sub has_time {
    $_[0]->has_hour && $_[0]->has_minute && $_[0]->has_second
}

sub defined_fields {  
    # no params, returns a list of fields  
    my $self = shift;  
    my @has = ();
    for ( @FIELDS_SORTED )
    {
        push @has, $_ if $self->_has( $_ );
    }
    return @has;
}  

sub can_be_datetime {  
    my $self = shift;  
    return 0 if ! $self->has_year;
    my $can = 1;
    for ( qw( month day hour minute second nanosecond ) )
    {
        return 0 if ! $can && $self->_has( $_ );
        $can = 0 if $can && ! $self->_has( $_ );
    }
    return 1;
}  

#sub become_datetime {
#    my $self = shift;
#    return undef unless $self->has_year;
#    # warn "param = @{[  %{$self->{has}}  ]} ";
#    # return DateTime->new( %{$self->{has}} );
#    my @parm = map { ( $_, $self->$_() ) } $self->defined_fields;
#    # warn "param = @parm";
#    return DateTime->new( @parm );
#}

sub set_time_zone
{
    die "set_time_zone() requires a time_zone value" unless $#_ == 1;
    my $time_zone = $_[1];
    if ( defined $time_zone )
    {
        $time_zone = DateTime::TimeZone->new( name => $time_zone ) unless ref $time_zone;
        $_[0]->{base}->set_time_zone( $time_zone ) if defined $_[0]->{base};
    }
    $_[0]->{has}{time_zone} = $time_zone;
}

sub _set_locale
{
    die "set_locale() requires a locale value" unless $#_ == 1;
    my $locale = $_[1];
    if ( defined $locale )
    {
        $locale = DateTime::Locale->load( $locale ) unless ref $locale;
        $_[0]->{base}->set( locale => $locale ) if defined $_[0]->{base};
    } 
    $_[0]->{has}{locale} = $locale;
}

sub clone 
{ 
    my $base;
    $base = $_[0]->{base}->clone if defined $_[0]->{base};
    bless { 
        has => { %{ $_[0]->{has} } }, 
        base => $base,
    }, 
    ref $_[0]; 
}

sub is_finite { 1 }
sub is_infinite { 0 }


sub truncate
{
    my $self = shift;
    my %p = validate( @_,
                      { to =>
                        { regex => qr/^(?:year|month|day|hour|minute|second)$/ },
                      },
                    );

    my @fields = @FIELDS;
    my $field;
    my $value;
    my $set = 0;

    while ( @fields )
    {
        ( $field, $value ) = ( shift @fields, shift @fields );
        $self->set( $field => $value ) if $set;
        $set = 1 if $p{to} eq $field;
    }
    return $self;
}


# Stringification methods

sub ymd
{
    my ( $self, $sep ) = ( @_, '-' );
    return $self->_year . $sep. $self->_month . $sep . $self->_day;
}
*date = \&ymd;

sub mdy
{
    my ( $self, $sep ) = ( @_, '-' );
    return $self->_month . $sep. $self->_day . $sep . $self->_year;
}

sub dmy
{
    my ( $self, $sep ) = ( @_, '-' );
    return $self->_day . $sep. $self->_month . $sep . $self->_year;
}

sub hms
{
    my ( $self, $sep ) = ( @_, ':' );
    return $self->_hour . $sep. $self->_minute . $sep . $self->_second;
}
# don't want to override CORE::time()
*DateTime::Incomplete::time = \&hms;

sub iso8601 { join 'T', $_[0]->ymd('-'), $_[0]->hms(':') }
*datetime = \&iso8601;


# "strftime"

# Modified from DateTime::strftime %formats; many changes.
my %formats =
    ( 'a' => sub { $_[0]->has_day ? 
                   $_[0]->day_abbr :
                   $UNDEF_CHAR x 3 },
      'A' => sub { $_[0]->has_day ? 
                   $_[0]->day_name :
                   $UNDEF_CHAR x 5 },
      'b' => sub { $_[0]->has_month ? 
                   $_[0]->month_abbr :
                   $UNDEF_CHAR x 3 },
      'B' => sub { $_[0]->has_month ? 
                   $_[0]->month_name :
                   $UNDEF_CHAR x 5 },
      'c' => sub { $_[0]->has_locale ?
                   $_[0]->strftime( $_[0]->locale->default_datetime_format ) :
                   $_[0]->datetime }, 
      'C' => sub { $_[0]->has_year ?
                   int( $_[0]->year / 100 ) :
                   $UNDEF_CHAR x 2},
      'd' => sub { $_[0]->_day },
      'D' => sub { $_[0]->strftime( '%m/%d/%y' ) },
      'e' => sub { $_[0]->has_month ? 
                   sprintf( '%2d', $_[0]->day_of_month ) :
                   " $UNDEF_CHAR" },
      'F' => sub { $_[0]->ymd('-') },
      'g' => sub { substr( $_[0]->week_year, -2 ) },
      'G' => sub { $_[0]->week_year },
      'H' => sub { $_[0]->_hour },   
      'I' => sub { $_[0]->has_hour ? 
                   sprintf( '%02d', $_[0]->hour_12 ) :
                   $UNDEF_CHAR x 2 },
      'j' => sub { defined $_[0]->day_of_year ? 
                   $_[0]->day_of_year :
                   $UNDEF_CHAR x 3 },
      'k' => sub { $_[0]->_hour },   
      'l' => sub { $_[0]->has_hour ? 
                   sprintf( '%2d', $_[0]->hour_12 ) :
                   " $UNDEF_CHAR" },
      'm' => sub { $_[0]->_month },  
      'M' => sub { $_[0]->_minute }, 
      'n' => sub { "\n" }, # should this be OS-sensitive?
      'N' => sub { (shift)->_format_nanosecs( @_ ) },   
      'p' => sub { $_[0]->_format_am_pm },           
      'P' => sub { lc $_[0]->_format_am_pm },     
      'r' => sub { $_[0]->strftime( '%I:%M:%S %p' ) },
      'R' => sub { $_[0]->strftime( '%H:%M' ) },
      's' => sub { $_[0]->_format_epoch }, 
      'S' => sub { $_[0]->_second }, 
      't' => sub { "\t" },
      'T' => sub { $_[0]->strftime( '%H:%M:%S' ) },
      'u' => sub { $_[0]->day_of_week },
      # algorithm from Date::Format::wkyr
      'U' => sub { my $dow = $_[0]->day_of_week;
                   return $UNDEF_CHAR x 2 unless defined $dow;
                   $dow = 0 if $dow == 7; # convert to 0-6, Sun-Sat
                   my $doy = $_[0]->day_of_year - 1;
                   return int( ( $doy - $dow + 13 ) / 7 - 1 )
                 },
      'w' => sub { my $dow = $_[0]->day_of_week;
                   return $UNDEF_CHAR unless defined $dow;
                   return $dow % 7;
                 },
      'W' => sub { my $dow = $_[0]->day_of_week;
                   return $UNDEF_CHAR x 2 unless defined $dow;
                   my $doy = $_[0]->day_of_year - 1;
                   return int( ( $doy - $dow + 13 ) / 7 - 1 )
                 },
      'x' => sub { $_[0]->has_locale ? 
                   $_[0]->strftime( $_[0]->locale->default_date_format ) :
                   $_[0]->date },
      'X' => sub { $_[0]->has_locale ?
                   $_[0]->strftime( $_[0]->locale->default_time_format ) :
                   $_[0]->time },
      'y' => sub { $_[0]->has_year ?  
                   sprintf( '%02d', substr( $_[0]->year, -2 ) ) :
                   $UNDEF_CHAR x 2 },
      'Y' => sub { $_[0]->_year },    
      'z' => sub { defined $_[0]->time_zone ?
                   DateTime::TimeZone::offset_as_string( $_[0]->offset ) :
                   $UNDEF_CHAR x 5 },
      'Z' => sub { defined $_[0]->time_zone ?
                   $_[0]->time_zone_short_name :
                   $UNDEF_CHAR x 5 },    
      '%' => sub { '%' },
    );

$formats{h} = $formats{b};

sub _format_epoch {
    my $epoch;
    $epoch = $_[0]->epoch;
    return $UNDEF_CHAR x 6 unless defined $epoch;
    return $epoch;
}

sub _format_am_pm { 
    defined $_[0]->locale ?
    $_[0]->locale->am_pm( $_[0] ) :
    $UNDEF_CHAR x 2
}

sub _format_nanosecs
{
    my $self = shift;
    my $precision = shift || 9;

    return $UNDEF_CHAR x $precision unless defined $self->nanosecond;

    # rd_nanosecs can have a fractional separator
    my ( $ret, $frac ) = split /[.,]/, $self->nanosecond;
    $ret = sprintf "09d" => $ret;  # unless length( $ret ) == 9;
    $ret .= $frac if $frac;

    return substr( $ret, 0, $precision );
}

sub strftime
{
    my $self = shift;
    # make a copy or caller's scalars get munged
    my @formats = @_;

    my @r;
    foreach my $f (@formats)
    {
        $f =~ s/
                                %{(\w+)}
                              /
                                if ( $self->can($1) ) 
                                {
                                        my $tmp = $self->$1();
                                        defined $tmp ?
                                                        $tmp :
                                                        ( exists $FIELD_LENGTH{$1} ?
                                                                      $UNDEF_CHAR x $FIELD_LENGTH{$1} :
                                                                      $UNDEF_CHAR x 2 );
                                }
                              /sgex;

        # regex from Date::Format - thanks Graham!
       $f =~ s/
                                %([%a-zA-Z])
                              /
                                $formats{$1} ? $formats{$1}->($self) : $1
                              /sgex;

        # %3N
        $f =~ s/
                                %(\d+)N
                              /
                                $formats{N}->($self, $1)
                              /sgex;

        return $f unless wantarray;

        push @r, $f;
    }

    return @r;
}

# DATETIME::INCOMPLETE METHODS


sub is_undef 
{
    for ( values %{$_[0]->{has}} )
    {
        return 0 if defined $_;
    }
    return 1;
}


sub to_datetime
{
    my $self = shift;
    my %param = @_;
    $param{base} = $self->{base} if defined $self->{base} &&
                                  ! exists $param{base};
    my $result;
    if ( defined $param{base} && 
         UNIVERSAL::can( $param{base}, 'utc_rd_values' ) )
    {
        $result = $param{base}->clone;
    }
    else
    {
        $result = DateTime->today;
    }
    my @params;
    for my $key ( @FIELDS_SORTED )
    {
        my $value = $self->{has}{$key};
        next unless defined $value;
        if ( $key eq 'time_zone' )
        {
            $result->set_time_zone( $value );
            next;
        }        
        push @params, ( $key => $value );
    }
    $result->set( @params );
    return $result;
}

sub contains {
    my $self = shift;
    my $dt = shift;
    die "no datetime" unless defined $dt && 
                             UNIVERSAL::can( $dt, 'utc_rd_values' );

    if ( $self->has_time_zone ) 
    {
        $dt = $dt->clone;
        $dt->set_time_zone( $self->time_zone );
    }

    my ($key, $value);
    while (($key, $value) = each %{$self->{has}} ) {
        next unless defined $value;
        if ( $key eq 'time_zone' ||
             $key eq 'locale' )
        {
            # time_zone and locale are ignored.
            next;
        }        
        return 0 unless $dt->$key() == $value;
    }
    return 1;
}

# _fix_time_zone
# internal method used by next, previous
#
sub _fix_time_zone {
    my ($self, $base, $code) = @_;
    $base = $self->{base} if defined $self->{base} &&
                                  ! defined $base;
    die "no base datetime" unless defined $base && 
                                  UNIVERSAL::can( $base, 'utc_rd_values' );
    my $base_tz = $base->time_zone;
    my $result = $base->clone;
    $result->set_time_zone( $self->time_zone )
        if $self->has_time_zone;
    $result = $code->($self, $result);
    return undef 
        unless defined $result;
    $result->set_time_zone( $self->time_zone )
        if $self->has_time_zone;
    $result->set_time_zone( $base_tz );
    return $result;
}

sub next
{
    # returns 'next or equal'
    my $self = shift;
    my $base = shift;

    return $self->_fix_time_zone( $base, 
        sub {
            my ($self, $result) = @_;
            REDO: for (1..10) {
                # warn "next: self ".$self->datetime." base ".$result->datetime;

                my @fields = @FIELDS;
                my ( $field, $overflow, $bigger_field );
                while ( @fields ) 
                {
                    ( $field, undef ) = ( shift @fields, shift @fields );
                    if ( defined $self->$field() )
                    {
                        $overflow = ( $self->$field() < $result->$field() );
                        return undef if $overflow && $field eq $FIELDS[0];

                        if ( $self->$field() != $result->$field() )
                        {
                            eval { $result->set( $field => $self->$field() ) }; 
                            if ( $@ ) 
                            {
                                $result->set( @fields );
                                eval { $result->set( $field => $self->$field() ) };
                                if ( $@ )
                                {
                                    $overflow = 1;
                                }
                            }

                            if ( $overflow ) 
                            {
                                $result->add( $bigger_field . 's' => 1 );
                                next REDO; 
                            }
                            else
                            {
                                $result->set( @fields );
                            }
                        }
                    }
                    $bigger_field = $field;
                }
                return $result;
            }
            return undef;
        } );
}

sub previous
{
    # returns 'previous or equal'
    my $self = shift;
    my $base = shift;

    return $self->_fix_time_zone( $base, 
        sub {
            my ($self, $result) = @_;
            # warn "# previous: self ".$self->datetime." base ".$result->datetime." ".$result->time_zone->name;

            my ( $field, $value, $overflow, $bigger_field );

            REDO: for (1..10) {
                my @fields = @FIELDS;
                while ( @fields ) 
                {
                    ( $field, $value ) = ( shift @fields, shift @fields );
                    if ( defined $self->$field() )
                    {
                        $overflow = ( $self->$field() > $result->$field() );
                        return undef if $overflow && $field eq $FIELDS[0];

                        if ( $self->$field() != $result->$field() )
                        {
                            if ( $overflow )
                            {
                                $result->set( $field => $value, @fields );
                                $result->subtract( nanoseconds => 1 );
                                next REDO;
                            }
                            my $diff = $result->$field() - $self->$field() ;
                            $diff--;
                            $result->subtract( $field  . 's' => $diff );
                            $result->set( @fields );
                            $result->subtract( nanoseconds => 1 );
                            if ( $result->$field() != $self->$field() )
                            {
                                $result->set( @fields );
                                $result->subtract( nanoseconds => 1 );
                            } 
                        }
                    }
                    $bigger_field = $field;
                }
                return $result;
            }
            return undef;
        } );
}

sub closest
{
    # returns 'closest datetime'

    my $self = shift;
    my $base = shift;
    $base = $self->{base} if defined $self->{base} &&
                                  ! defined $base;
    die "no base datetime" unless defined $base &&
                                  UNIVERSAL::can( $base, 'utc_rd_values' );

    my $dt1 = $self->previous( $base );
    my $dt2 = $self->next( $base );

    return $dt1 unless defined $dt2;
    return $dt2 unless defined $dt1;

    my $delta = $base - $dt1;
    return $dt1 if ( $dt2 - $delta ) >= $base;
    return $dt2;
}

sub start
{
    my $self = shift;
    return undef unless $self->has_year;
    my $dt = $self->to_datetime;
    $dt->subtract( years => 1 );
    return $self->next( $dt );
}

sub end
{
    my $self = shift;
    return undef unless $self->has_year;
    my $dt = $self->to_datetime;
    $dt->add( years => 1 );
    my $end = $self->previous( $dt );
    $end->add( nanoseconds => 1 ) unless $self->has_nanosecond;
    return $end;
}

sub to_span
{
    my $self = shift;
    my $start = $self->start;
    my $end = $self->end;

    return DateTime::Set->empty_set->complement->span
        if ! $start && ! $end;

    my @start;
    @start = ( 'start', $start ) if $start;

    my @end;
    if ( $end )
    {
        if ( $self->has_nanosecond )
        {
            @end = ( 'end', $end ); 
        }
        else
        {
            @end = ( 'before', $end ); 
        }
    }

    return DateTime::Span->from_datetimes( @start, @end );
}

sub to_recurrence
{
    my $self = shift;
    my %param;

    my $freq = '';
    my $year;
    for ( qw( second minute hour day month year ) )
    {
        my $by = $_ . 's';  # months, hours
        if ( exists $self->{has}{$_} && defined $self->{has}{$_} )
        {
            if ( $_ eq 'year' ) 
            {
                $year = $self->$_();
                next;
            }
            $param{$by} = [ $self->$_() ];
            next;
        }
        $freq = $_ unless $freq;
        # TODO: use a hash
        $param{$by} = [ 1 .. 12 ] if $_ eq 'month';
        $param{$by} = [ 1 .. 31 ] if $_ eq 'day';
        $param{$by} = [ 0 .. 23 ] if $_ eq 'hour';
        $param{$by} = [ 0 .. 59 ] if $_ eq 'minute';
        $param{$by} = [ 0 .. 59 ] if $_ eq 'second';
    }
    if ( $freq eq '' )
    {
        # it is a single date
        my $dt = DateTime->new( %{$self->{has}} );
        return DateTime::Set->from_datetimes( dates => [ $dt ] );
    }

    # for ( keys %param ) { print STDERR " param $_ = @{$param{$_}} \n"; }

    my $r = DateTime::Event::Recurrence->yearly( %param );
    if ( defined $year ) {
        my $span = DateTime::Span->from_datetimes( 
                       start => DateTime->new( year => $year ),
                       before => DateTime->new( year => $year + 1 ) );
        $r = $r->intersection( $span );
    }
    return $r;
}

sub to_spanset
{
    my $self = shift;
    my @reset;
    for ( qw( second minute hour day month year ) )
    {
        if ( $self->has( $_ ) )
        {
            my %fields = @FIELDS;
            @reset = map { $_ => $fields{$_} } @reset;
            my $dti = $self->clone;
            $dti->set( @reset ) if @reset;

            return DateTime::SpanSet->from_set_and_duration (
                set => $dti->to_recurrence,
                $_ . 's' => 1,
            );
        }
        push @reset, $_;
    }
    return $self->to_span;
}

sub STORABLE_freeze
{
    my ( $self, $cloning ) = @_;
    return if $cloning;

    my @data;
    for my $key ( @FIELDS_SORTED )
    {
        next unless defined $self->{has}{$key};

        if ( $key eq 'locale' ) 
        { 
            push @data,  "locale:" . $self->{has}{locale}->id; 
        }
        elsif ( $key eq 'time_zone' ) 
        { 
            push @data, "tz:" . $self->{has}{time_zone}->name; 
        }
        else 
        { 
            push @data, "$key:" . $self->{has}{$key}; 
        }
    }
    return join( '|', @data ), [$self->base];
}

sub STORABLE_thaw
{
    my ( $self, $cloning, $data, $base ) = @_;
    my %data = map { split /:/ } split /\|/, $data;
    my $locale = delete $data{locale};
    my $tz =     delete $data{tz};
    $self->{has} = \%data;
    $self->set_time_zone( $tz );
    $self->set( locale => $locale );
    $self->{base} = $base->[0];
    return $self;
}

1;

__END__

#=item * become_datetime
#
#Returns a C<DateTime> object.
#
#Returns C<undef> if the year value is not set.
#
#This method may C<die> if the parameters are not valid 
#in the call to  C<DateTime->new>.