From dc07be4ac45756a0e664ee29e888f86b7609784a Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Thu, 10 Nov 2011 15:10:26 +0000 Subject: move up a level --- attr.pl | 363 ---------------------------------------------------------------- 1 file changed, 363 deletions(-) delete mode 100644 attr.pl (limited to 'attr.pl') diff --git a/attr.pl b/attr.pl deleted file mode 100644 index de90bd8..0000000 --- a/attr.pl +++ /dev/null @@ -1,363 +0,0 @@ -#!/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, C and -C<$meta_instance->set_slot_value> (or C) 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, 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 - -- cgit v1.2.3