path: root/attr.pl

#!/usr/bin/perl 
 
=head1 SYNOPSIS
 
  package My::Class;
  use Moose;
 
  has stuff => (
    is => 'rw',
    isa => 'Int',
    traits => ['Timed'],
    predicate => 'has_stuff',
    clearer => 'clear_stuff',
  );
 
Later:
 
  my $obj = My::Class->new();
 
  $obj->stuff(3); # sets value for every interval
  $obj->stuff_timed({},3); # sets value the "default" interval
  $obj->stuff_timed({from=>$timestamp,to=>$timestamp2},3); # sets value for the given time interval
 
  print $obj->stuff(); # value for time();
  print $obj->stuff_timed(); # as above
  print $obj->stuff_timed({when=>$timestamp}); # as above, for given time
 
  print $obj->has_stuff(); # true if we have a value for time()
  print $obj->has_stuff_timed(); # as above
  print $obj->has_stuff_timed({when=>$timestamp}); # as above, for given time
 
  $obj->clear_stuff(); # deletes everything
  $obj->clear_stuff_timed({}); # deletes the "default" interval
  $obj->clear_stuff_timed({from=>$timestamp,to=>$timestamp2}); # deletes the given time interval
 
=cut
 
use strict;
use warnings all=>'FATAL';
 
package My::Attribute;{ 
use Moose::Role;
use MooseX::Types::Moose qw(ArrayRef Int Any);
use MooseX::Types::Structured qw(Dict);
use Moose::Util::TypeConstraints ();
use namespace::autoclean;
 
before _process_options => sub {
    my ($self, $name, $options) = @_;
 
    my $value_type;
    $value_type //= $options->{isa} ?
        Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa})
              : undef;
    $value_type //= $options->{does} ?
        Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does})
              : undef;
 
    $value_type //= Any;
 
    $options->{isa} = ArrayRef[Dict[
        from => Int,
        to => Int,
        value => $value_type,
    ]];
};
 
sub accessor_metaclass { 'My::Accessor' }
 
after install_accessors => sub {
    my ($self) = @_;
 
    my $class  = $self->associated_class;
 
    for my $meth (qw(accessor reader writer predicate clearer)) {
        my $check = "has_$meth";
        next unless $self->$check;
 
        my $type = "timed_$meth";
        my $basename = $self->$meth;
        my $name = "${basename}_timed";
 
        $class->add_method(
            $self->_process_accessors($type => $name,0)
        );
    }
};
 
use Data::Printer;
 
sub _find_interval_for {
    my ($self,$all_values,$when) = @_;
 
    my $default;
 
    for my $interval (@$all_values) {
        if ($interval->{from}==0 and $interval->{to}==0) {
            $default = $interval;
            next;
        }
        next if $interval->{from} > $when;
        next if $interval->{to} <= $when;
        return $interval;
    }
    return $default;
}
 
sub get_timed_value {
    my ($self,$instance,$opts,$for_trigger) = @_;
 
    print join ', ',caller;
    printf " get_timed_value(%s)\n",p($opts);
 
    my $when = $opts->{when} // $opts->{from} // time();
 
    my $all_values = $self->get_value($instance,$for_trigger);
 
    return unless $all_values && @$all_values;
 
    my $interval = $self->_find_interval_for($all_values,$when);
 
    return unless defined $interval;
 
    return $interval->{value};
}
 
sub set_timed_value {
    my ($self,$instance,$opts,$value) = @_;
 
    print join ', ',caller;
    printf " set_timed_value(%s,%s)\n",p($opts),p($value);
 
    if ($opts->{forever}) {
        $self->set_value($instance,[
            {
                from => 0,
                to => 0,
                value => $value,
            },
        ]);
    }
    else {
        my $interval = {
            from => $opts->{from}//0,
            to => $opts->{to}//0,
            value => $value,
        };
 
        # XXX this has to take into account interval intersections &c 
        my $all_values = $self->get_value($instance);
        push @$all_values,$interval;
        $self->set_value($instance,$all_values);
    }
}
 
sub has_timed_value {
    my ($self,$instance,$opts) = @_;
 
    print join ', ',caller;
    printf " has_timed_value(%s)\n",p($opts);
 
    return unless $self->has_value($instance);
 
    my $when = $opts->{when} // time();
 
    my $all_values = $self->get_value($instance);
 
    return unless $all_values && @$all_values;
 
    return defined $self->_find_interval_for($all_values,$when);
}
 
sub clear_timed_value {
    my ($self,$instance,$opts) = @_;
 
    print join ', ',caller;
    printf " clear_timed_value(%s)\n",p($opts);
 
    if ($opts->{forever}) {
        $self->clear_value($instance);
    }
    # should do intersections &c 
    die "unimplemented";
}
};
 
package Moose::Meta::Attribute::Custom::Trait::Timed;{ 
sub register_implementation { 'My::Attribute' }
}
 
package My::Accessor;{ 
use base 'Moose::Meta::Method::Accessor';
use Carp 'confess';
 
sub _instance_is_inlinable { 0 }
 
sub _generate_accessor_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        if (@_ >= 2) {
            $attr->set_timed_value($_[0], {forever=>1}, $_[1]);
        }
        $attr->get_timed_value($_[0], {when=>time()});
    }
}
 
sub _generate_reader_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        confess "Cannot assign a value to a read-only accessor"
            if @_ > 1;
        $attr->get_timed_value($_[0], {when=>time()});
    };
}
 
sub _generate_writer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        $attr->set_timed_value($_[0], {forever=>1}, $_[1]);
    };
}
 
sub _generate_predicate_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        $attr->has_timed_value($_[0], {when=>time()})
    };
}
 
sub _generate_clearer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        $attr->clear_timed_value($_[0], {forever=>1})
    };
}
 
sub _generate_timed_accessor_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        if (@_ >= 3) {
            $attr->set_timed_value($_[0], $_[1], $_[2]);
        }
        $attr->get_timed_value($_[0],$_[1]);
    }
}
 
sub _generate_timed_reader_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        confess "Cannot assign a value to a read-only accessor"
            if @_ > 2;
        $attr->get_timed_value($_[0],$_[1]);
    };
}
 
sub _generate_timed_writer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        $attr->set_timed_value($_[0], $_[1], $_[2]);
    };
}
 
sub _generate_timed_predicate_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        $attr->has_timed_value($_[0],$_[1])
    };
}
 
sub _generate_timed_clearer_method {
    my $self = shift;
    my $attr = $self->associated_attribute;
 
    return sub {
        $attr->clear_timed_value($_[0],$_[1])
    };
}
};
 
package Foo;{ 
use Moose;
use MooseX::Types::Moose qw(Int);
 
has stuff => (
    is => 'rw',
    isa => Int,
    traits => ['Timed'],
    predicate => 'has_stuff',
    clearer => 'has_stuff',
);
}
 
package main;{ 
use Data::Printer;
use 5.012;
 
my $obj = Foo->new();
 
p $obj;
 
say $obj->stuff(2);
 
eval { say $obj->stuff('wrong') } or say $@;
 
say $obj->stuff_timed({from=>10,to=>20},5);
say $obj->stuff_timed({},3);
 
p $obj;
 
say $obj->stuff();
say $obj->stuff_timed({});
say $obj->stuff_timed({when=>12});
 
}
 
=pod
 
=head1 NOTES
 
we could override C<set_raw_value>, C<get_raw_value> and
C<$meta_instance->set_slot_value> (or C<set_initial_value>) on the
L<::Meta::Attribute>.
 
that would take care of type constraints, while leaving us free to use
an arbitrary internal representation.
 
no inlining, it's too awkward
 
=head2 internal representation
 
not easy… we need something like L<Array::IntSpan>, but slightly less
insane, with added tagging (we can't sensibly decouple intervals from
tags/envs, the representations would clash)
 
suggestion: per each tag:
 
arrayref, position 0 = default (-inf,inf)
 
other elements set in asc order of start
 
binary search (on start, with additional check on end) to find the
right place to read from
 
split / remove elements when setting / clearing