summaryrefslogtreecommitdiff
path: root/attr.pl
diff options
context:
space:
mode:
Diffstat (limited to 'attr.pl')
-rw-r--r--attr.pl363
1 files changed, 0 insertions, 363 deletions
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<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
-
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-19 11:07:42 +0000