/usr/share/perl5/Tangram/Type/Abstract/Hash.pm is in libtangram-perl 2.10-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | use strict;
package Tangram::Type::Abstract::Hash;
use Tangram::Type::Abstract::Coll;
use vars qw(@ISA);
@ISA = qw( Tangram::Type::Abstract::Coll );
use Carp;
sub content
{
shift;
@{shift()};
}
sub demand
{
my ($self, $def, $storage, $obj, $member, $class) = @_;
my %coll;
if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$storage->export_object($obj)})
{
print $Tangram::TRACE "demanding ".$storage->id($obj)
.".$member from prefetch\n" if $Tangram::TRACE;
%coll = %$prefetch;
}
else
{
print $Tangram::TRACE "demanding ".$storage->id($obj)
.".$member from storage\n" if $Tangram::TRACE;
my $cursor = $self->cursor($def, $storage, $obj, $member);
my @lost;
for (my $item = $cursor->select; $item; $item = $cursor->next)
{
my $slot = shift @{ $cursor->{-residue} };
if (!defined($slot)) {
warn "object ".$storage->id($item)." has no slot in hash ".$storage->id($obj)."/$member!";
push @lost, $item;
} else {
$coll{$slot} = $item;
}
}
# Try to DTRT when you've got NULL slots, though this
# isn't much of a RT to D.
while (@lost) {
my $c = 0;
while (!exists $coll{$c++}) { }
$coll{$c} = shift @lost;
}
}
$self->set_load_state($storage, $obj, $member, { map { ($_ ? ($_ => ($coll{$_} && $storage->id( $coll{$_} ) ) ) : ()) } keys %coll } );
return \%coll;
}
sub save_content
{
my ($obj, $field, $context) = @_;
# has collection been loaded? if not, then it hasn't been modified
my $tied = tied $obj->{$field};
my $storage = $context->{storage};
if ($tied and $tied->can("storage")
and $tied->storage == $storage ) {
#print STDERR "not saving $obj -> {$field} (tied = $tied)\n";
return;
}
return unless exists $obj->{$field} && defined $obj->{$field};
foreach my $item (values %{ $obj->{$field} }) {
$storage->insert($item)
unless $storage->id($item);
}
}
sub get_exporter
{
my ($self, $context) = @_;
my $field = $self->{name};
return sub {
my ($obj, $context) = @_;
my $tied = tied $obj->{$field};
my $storage = $context->{storage};
if ($tied and $tied->can("storage")
and $tied->storage == $storage ) {
#print STDERR "not saving $obj -> {$field} (tied = $tied)\n";
return;
}
return unless exists $obj->{$field} && defined $obj->{$field};
foreach my $item (values %{ $obj->{$field} }) {
$storage->insert($item)
unless $storage->id($item);
}
$context->{storage}->defer(sub { $self->defered_save($obj, $field, $storage) } );
();
}
}
1;
|