lib/WebCoso/Resource.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112

package WebCoso::Resource; 
use strict;
use warnings;
use Class::Std;
#use WebCoso::X; 
#use Smart::Comments;$Data::Dumper::Useqq=1; 
 
{
my %values_of :ATTR(:default<{}>);
my %propnames_of :ATTR(:default<{}>);
my %axes_of :ATTR(:default<{}>);
 
sub get_axes {
    my ($self)=@_;
 
    return keys %{$axes_of{ident $self}};
}
 
sub get_axis_values {
    my ($self,$axis_name)=@_;
 
    return keys %{$axes_of{ident $self}->{$axis_name}};
}
 
sub set_property {
    my $self=shift;
    my $axes_spec= (ref($_[0]) eq 'HASH') ? (shift) : {};
    my ($prop_name,$prop_value)=@_;
 
    $self->_populate_axes_from($axes_spec);
    my $key=_genkey($axes_spec);
 
    $propnames_of{ident $self}->{$prop_name}=undef;
 
    $values_of{ident $self}->{$prop_name}->{$key}=$prop_value;
 
    return;
}
 
sub get_property {
    my $self=shift;
    my $axes_spec= (ref($_[0]) eq 'HASH') ? (shift) : {};
    my ($prop_name)=@_;
 
    ### $self 
    ### $axes_spec 
    ### $prop_name 
 
    my $req_key=_genkey($axes_spec);
 
    my $values_ref=$values_of{ident $self}->{$prop_name};
 
    ### $values_ref 
 
    my @keys=sort {($a=~tr/\001//) <=> ($b=~tr/\001//)} keys %$values_ref;
 
    for my $key (@keys) {
        ### testing key: $key 
 
        my $key_rx=_genrx_from_key($key);
 
        if ($req_key =~ m{$key_rx}) {
            return $values_ref->{$key};
        }
    }
 
    return;
}
 
sub _populate_axes_from {
    my ($self,$axes_spec)=@_;
 
    while (my ($axis_name,$axis_value)=each %$axes_spec) {
        my $axis_value_set=($axes_of{ident $self}->{$axis_name} ||= {});
        $axis_value_set->{$axis_value}=undef;
    }
 
    return;
}
 
sub _genkey {
    my ($axes_spec)=@_;
 
    my $key="\000";
    $key.=join "\000",map {$_."\001".$axes_spec->{$_}} sort keys %$axes_spec;
    $key.="\000";
 
    ### chiave: $key 
 
    return $key;
}
 
sub _genrx_from_key {
    my ($key)=@_;
 
    my (undef,@axes)=split /\000/,$key;
 
    ### axes form key: \@axes 
 
    my $rx="(?:";
    $rx.=join "\000).*?(?:",map {quotemeta($_)} @axes;
    $rx.=")";
    $rx=qr{^\000.*?${rx}(?:\000|$)};
 
    ### regexp: $rx 
 
    return $rx;
}
 
}
 
1;