From ecb40d33f54324c9c296d38da9cdc8c928152179 Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Tue, 8 Nov 2011 17:17:26 +0000 Subject: first stab! --- attr.pl | 329 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 329 insertions(+) create mode 100644 attr.pl (limited to 'attr.pl') 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}); + +} -- cgit v1.2.3