package WebCoso::Resource;
use strict;
use warnings;
use Class::Std;
use Scalar::Util 'weaken';
use List::MoreUtils 'any';
{
my %values_of :ATTR(:default<{}>);
my %propnames_of :ATTR(:default<{}>);
my %axes_of :ATTR(:default<{}>);
my %collections_of :ATTR(:get<collections_ref> :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)=@_;
return unless exists $values_of{ident $self}->{$prop_name};
my $values_ref=$values_of{ident $self}->{$prop_name};
my $req_key=_genkey($axes_spec);
my @keys=sort {($a=~tr/\001//) <=> ($b=~tr/\001//)} keys %$values_ref;
for my $key (@keys) {
my $key_rx=_genrx_from_key($key);
if ($req_key =~ m{$key_rx}) {
return $values_ref->{$key};
}
}
return;
}
sub get_property_fh {
my $self=shift;
my $axes_spec= (ref($_[0]) eq 'HASH') ? (shift) : {};
my ($prop_name)=@_;
my $prop_value=$self->get_property($axes_spec,$prop_name);
return unless defined $prop_value;
if (ref($prop_value) eq 'CODE') {
$prop_value=$prop_value->();
}
if (ref($prop_value)) {
open my $fh,'<&',$prop_value;
seek $fh,0,0;
return $fh;
}
else {
my $val="$prop_value";
open my $fh,'<',\$val;
return $fh;
}
}
sub get_property_string {
my $self=shift;
my $axes_spec= (ref($_[0]) eq 'HASH') ? (shift) : {};
my ($prop_name)=@_;
my $prop_value=$self->get_property($axes_spec,$prop_name);
return unless defined $prop_value;
if (ref($prop_value) eq 'CODE') {
$prop_value=$prop_value->();
}
if (ref($prop_value)) {
seek $prop_value,0,0;
return do {local $/;<$prop_value>}
}
else {
return "$prop_value";
}
}
sub get_collections {
my ($self)=@_;
return @{ $self->get_collections_ref() };
}
sub add_coll {
my ($self, $collection)=@_;
return if any { $_ eq $collection } @{ $self->get_collections_ref() };
my $weak_collection = $collection;
weaken $weak_collection;
push @{ $self->get_collections_ref() }, $weak_collection;
$collection->add_res($self);
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";
return $key;
}
sub _genrx_from_key {
my ($key)=@_;
my (undef,@axes)=split /\000/,$key;
my $rx="(?:";
$rx.=join "\000).*?(?:",map {quotemeta($_)} @axes;
$rx.=")";
$rx=qr{^\000.*?${rx}(?:\000|$)};
return $rx;
}
}
1;