first stab!

1 files changed, 329 insertions, 0 deletions

diff --git a/attr.pl b/attr.pl
new file mode 100644
index 0000000..8a53889
--- /dev/null
+++ b/attr.pl
@@ -0,0 +1,329 @@
+#!/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);
+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});
+
+}