line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package RDF::Helper::TiedPropertyHash; |
2
|
11
|
|
|
11
|
|
43
|
use strict; |
|
11
|
|
|
|
|
65
|
|
|
11
|
|
|
|
|
275
|
|
3
|
11
|
|
|
11
|
|
38
|
use warnings; |
|
11
|
|
|
|
|
13
|
|
|
11
|
|
|
|
|
329
|
|
4
|
|
|
|
|
|
|
require Tie::Hash; |
5
|
11
|
|
|
11
|
|
34
|
use Data::Dumper; |
|
11
|
|
|
|
|
14
|
|
|
11
|
|
|
|
|
404
|
|
6
|
11
|
|
|
11
|
|
41
|
use vars qw( @ISA ); |
|
11
|
|
|
|
|
12
|
|
|
11
|
|
|
|
|
753
|
|
7
|
|
|
|
|
|
|
@ISA = qw( Tie::ExtraHash ); |
8
|
|
|
|
|
|
|
use overload |
9
|
11
|
|
|
|
|
288
|
'""' => \&overload_uri, |
10
|
|
|
|
|
|
|
'eq' => \&overload_uri_equals, |
11
|
11
|
|
|
11
|
|
328
|
'==' => \&overload_uri_equals; |
|
11
|
|
|
|
|
15
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub new { |
14
|
0
|
|
|
0
|
0
|
|
my $proto = shift; |
15
|
0
|
|
|
|
|
|
my %args = @_; |
16
|
0
|
|
|
|
|
|
my %data; |
17
|
|
|
|
|
|
|
|
18
|
0
|
0
|
|
|
|
|
unless ( $args{Helper} ) { |
19
|
0
|
|
|
|
|
|
eval "require RDF::Helper"; |
20
|
0
|
|
|
|
|
|
$args{Helper} = RDF::Helper->new( BaseInterface => 'RDF::Redland' ); |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
tie %data, |
24
|
|
|
|
|
|
|
'RDF::Helper::TiedPropertyHash', |
25
|
|
|
|
|
|
|
$args{Helper}, |
26
|
|
|
|
|
|
|
$args{ResourceURI}, |
27
|
0
|
|
|
|
|
|
$args{Options}; |
28
|
0
|
|
|
|
|
|
return \%data; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
#---------------------------------------- |
32
|
|
|
|
|
|
|
# here, $self is an array ref with the following indices |
33
|
|
|
|
|
|
|
# 0 -- a ref to the hash we're operation on |
34
|
|
|
|
|
|
|
# 1 -- a ref to the RDF::Helper object that suppies the backend |
35
|
|
|
|
|
|
|
# 2 -- The subject URI associated with this set of properties. |
36
|
|
|
|
|
|
|
#---------------------------------------- |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub TIEHASH { |
39
|
0
|
|
|
0
|
|
|
my $class = shift; |
40
|
0
|
|
|
|
|
|
my ( $helper, $lookup_uri, $options ) = @_; |
41
|
0
|
|
0
|
|
|
|
$options ||= { |
42
|
|
|
|
|
|
|
Deep => 0 |
43
|
|
|
|
|
|
|
}; |
44
|
0
|
|
|
|
|
|
my $data = {}; |
45
|
|
|
|
|
|
|
|
46
|
0
|
0
|
|
|
|
|
unless ( defined $helper ) { |
47
|
0
|
|
|
|
|
|
eval "require RDF::Helper"; |
48
|
0
|
|
|
|
|
|
$helper = RDF::Helper->new( BaseInterface => 'RDF::Redland' ); |
49
|
|
|
|
|
|
|
} |
50
|
0
|
0
|
|
|
|
|
if ( defined $lookup_uri ) { |
51
|
0
|
|
|
|
|
|
foreach my $stmnt ( $helper->get_statements( $lookup_uri, undef, undef ) ) { |
52
|
0
|
|
|
|
|
|
my $predicate = $stmnt->predicate->uri->as_string; |
53
|
0
|
|
|
|
|
|
my $prop_key = $helper->resolved2prefixed( $predicate ); |
54
|
0
|
|
|
|
|
|
push @{$data->{$prop_key}}, $stmnt->object; |
|
0
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
else { |
58
|
0
|
|
|
|
|
|
$lookup_uri = $helper->new_bnode; |
59
|
|
|
|
|
|
|
} |
60
|
0
|
|
|
|
|
|
bless [$data, $helper, $lookup_uri, $options], $class; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
sub DELETE { |
64
|
0
|
|
|
0
|
|
|
my $self = shift; |
65
|
0
|
|
|
|
|
|
my $key = shift; |
66
|
0
|
|
|
|
|
|
my $prop_uri = $self->[1]->prefixed2resolved( $key ); |
67
|
0
|
|
|
|
|
|
$self->[1]->remove_statements( $self->[2], $prop_uri ); |
68
|
0
|
|
|
|
|
|
my @results = map { $self->_node_value($_) } @{$self->[0]->{$key}}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
69
|
0
|
|
|
|
|
|
delete $self->[0]->{$key}; |
70
|
0
|
0
|
|
|
|
|
if ($#results > 0) { |
71
|
0
|
|
|
|
|
|
return \@results; |
72
|
|
|
|
|
|
|
} else { |
73
|
0
|
|
|
|
|
|
return $results[0]; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub CLEAR { |
78
|
|
|
|
|
|
|
#warn "clear called!!!!"; |
79
|
0
|
|
|
0
|
|
|
my $self = shift; |
80
|
0
|
|
|
|
|
|
my $key = shift; |
81
|
0
|
|
|
|
|
|
$self->[1]->remove_statements( $self->[2] ); |
82
|
0
|
|
|
|
|
|
%{$self->[0]} = (); |
|
0
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub FETCH { |
86
|
0
|
|
|
0
|
|
|
my $self = shift; |
87
|
0
|
|
|
|
|
|
my $key = shift; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
# Return the resource URI of this hash if requested |
90
|
0
|
0
|
|
|
|
|
if ($key eq 'resource_uri') { |
91
|
0
|
|
|
|
|
|
return $self->[2]; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# Otherwise, return the property value |
95
|
0
|
0
|
0
|
|
|
|
if (defined($self->[0]->{$key}) and ref($self->[0]->{$key}) eq 'ARRAY' and scalar(@{$self->[0]->{$key}}) > 0) { |
|
0
|
|
0
|
|
|
|
|
96
|
0
|
|
|
|
|
|
my @results = (); |
97
|
0
|
|
|
|
|
|
foreach my $obj (@{$self->[0]->{$key}}) { |
|
0
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# Find the node's value |
100
|
0
|
|
|
|
|
|
my $val = $self->_node_value($obj); |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# If it's a resource, make it an object |
103
|
0
|
0
|
0
|
|
|
|
if ($self->[3]->{Deep} and ($obj->is_resource or $obj->is_blank)) { |
|
|
|
0
|
|
|
|
|
104
|
0
|
|
|
|
|
|
$val = $self->[1]->tied_property_hash( $val ); |
105
|
|
|
|
|
|
|
} |
106
|
0
|
|
|
|
|
|
push @results, $val; |
107
|
|
|
|
|
|
|
} |
108
|
0
|
0
|
|
|
|
|
if ($#results > 0) { |
109
|
0
|
|
|
|
|
|
return \@results; |
110
|
|
|
|
|
|
|
} else { |
111
|
0
|
|
|
|
|
|
return $results[0]; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
} |
114
|
0
|
|
|
|
|
|
return undef; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub STORE { |
118
|
0
|
|
|
0
|
|
|
my $self = shift; |
119
|
0
|
|
|
|
|
|
my ($key, $value) = @_; |
120
|
|
|
|
|
|
|
|
121
|
0
|
|
|
|
|
|
my $val_type = $self->[1]->get_perl_type( $value ); |
122
|
0
|
|
|
|
|
|
my $prop_uri = $self->[1]->prefixed2resolved( $key ); |
123
|
0
|
|
|
|
|
|
my $old_val = $self->[0]->{$key}; |
124
|
|
|
|
|
|
|
|
125
|
0
|
0
|
0
|
|
|
|
if ( defined $old_val and ref($old_val) eq 'ARRAY' and scalar(@$old_val) > 0) { |
|
|
|
0
|
|
|
|
|
126
|
0
|
|
|
|
|
|
$self->[1]->remove_statements( $self->[2], $prop_uri ); |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
0
|
0
|
0
|
|
|
|
if ( $val_type eq 'literal' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
130
|
0
|
|
|
|
|
|
$self->[1]->assert_literal( $self->[2], $prop_uri, $value ) |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
elsif ( $val_type eq 'resource' or $val_type eq 'SCALAR') { |
133
|
0
|
|
|
|
|
|
$self->[1]->assert_resource( $self->[2], $prop_uri, $value ) |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
elsif ( $val_type eq 'ARRAY' ) { |
136
|
0
|
|
|
|
|
|
foreach my $v ( @{$value} ) { |
|
0
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# this is dubious |
138
|
0
|
|
|
|
|
|
my $type = $self->[1]->get_perl_type( $v ); |
139
|
|
|
|
|
|
|
|
140
|
0
|
0
|
|
|
|
|
if ( $type eq 'resource' ) { |
141
|
0
|
|
|
|
|
|
$self->[1]->assert_resource( $self->[2], $prop_uri, $v ); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
else { |
144
|
0
|
|
|
|
|
|
$self->[1]->assert_literal( $self->[2], $prop_uri, $v ); |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
# get smarter here |
149
|
|
|
|
|
|
|
else { |
150
|
0
|
|
|
|
|
|
die "I do not know how to store value of reference type '$val_type' as RDF, please contact the module author"; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
0
|
|
|
|
|
|
$self->[0]->{$key} = [ map { $_->object } $self->[1]->get_statements( $self->[2], $prop_uri, undef ) ]; |
|
0
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub _node_value { |
157
|
0
|
|
|
0
|
|
|
my $self = shift; |
158
|
0
|
|
|
|
|
|
my $obj = shift; |
159
|
0
|
0
|
|
|
|
|
return $obj unless (ref($obj)); |
160
|
|
|
|
|
|
|
|
161
|
0
|
0
|
|
|
|
|
if ($obj->is_literal) { |
|
|
0
|
|
|
|
|
|
162
|
0
|
|
|
|
|
|
return $obj->literal_value; |
163
|
|
|
|
|
|
|
} elsif ($obj->is_resource) { |
164
|
0
|
|
|
|
|
|
return $obj->uri->as_string; |
165
|
|
|
|
|
|
|
} else { |
166
|
0
|
|
|
|
|
|
return $obj->as_string; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub overload_uri { |
171
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
172
|
0
|
|
|
|
|
|
return $self->[2]; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
sub overload_uri_equals { |
176
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
177
|
0
|
|
|
|
|
|
my $value = shift; |
178
|
0
|
|
|
|
|
|
return $self->[2] eq $value; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
1; |