/usr/share/perl5/Tangram/Type/Hash/FromMany.pm is in libtangram-perl 2.12-1.
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 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | use strict;
package Tangram::Type::Hash::FromMany;
use Tangram::Type::Abstract::Hash;
use vars qw(@ISA);
@ISA = qw( Tangram::Type::Abstract::Hash );
use Carp;
sub reschema
{
my ($self, $members, $class, $schema) = @_;
foreach my $member (keys %$members)
{
my $def = $members->{$member};
unless (ref($def))
{
# XXX - not tested by test suite
$def = { class => $def };
$members->{$member} = $def;
}
$def->{table} ||= $schema->{normalize}->($def->{class} . "_$member", 'tablename');
$def->{coll} ||= 'coll';
$def->{item} ||= 'item';
$def->{slot} ||= 'slot';
$def->{quote} = !exists $def->{key_type} || $def->{key_type} eq 'string' ? "'" : '';
}
return keys %$members;
}
sub defered_save {
my ($self, $obj, $field, $storage) = @_;
my $coll_id = $storage->export_object($obj);
my ($table, $coll_col, $item_col, $slot_col) = @{ $self }{ qw( table coll item slot ) };
my $Q = $self->{quote};
my $coll = $obj->{$field};
my $old_state = $self->get_load_state($storage, $obj, $field) || {};
my %removed = %$old_state;
delete @removed{ keys %$coll };
my @free = keys %removed;
my %new_state;
foreach my $slot (keys %$coll)
{
my $item_id = $storage->export_object($coll->{$slot});
if (exists $old_state->{$slot})
{
# key already exists
# XXX - not reached by test suite
if ($item_id != $old_state->{$slot})
{
# val has changed
$storage->sql_do
( "UPDATE\n $table\nSET\n $item_col = $item_id\nWHERE\n $coll_col = $coll_id AND\n $slot_col = $Q$slot$Q" );
}
}
else
{
# key does not exist
if (@free)
{
# recycle an existing line
# XXX - not reached by test suite
my $rslot = shift @free;
$storage->sql_do(
"UPDATE\n $table\nSET\n $slot_col = $Q$slot$Q,\n $item_col = $item_id\nWHERE\n $coll_col = $coll_id AND\n $slot_col = $Q$rslot$Q" );
}
else
{
# insert a new line
$storage->sql_do(
"INSERT INTO $table ($coll_col, $item_col, $slot_col)\n VALUES ($coll_id, $item_id, $Q$slot$Q)" );
}
}
$new_state{$slot} = $item_id;
} # foreach my $slot (keys %$coll)
# remove lines in excess
if (@free)
{
# XXX - not reached by test suite
@free = map { "$Q$_$Q" } @free if $Q;
$storage->sql_do( "DELETE FROM\n $table\nWHERE\n $coll_col = $coll_id AND\n $slot_col IN (@free)" );
}
$self->set_load_state($storage, $obj, $field, \%new_state );
$storage->tx_on_rollback( sub { $self->set_load_state($storage, $obj, $field, $old_state) } );
}
sub erase
{
my ($self, $storage, $obj, $members, $coll_id) = @_;
foreach my $member (keys %$members)
{
my $def = $members->{$member};
my $table = $def->{table} || $def->{class} . "_$member";
my $coll_col = $def->{coll} || 'coll';
my $sql = "DELETE FROM\n $table\nWHERE\n $coll_col = $coll_id";
$storage->sql_do($sql);
}
}
sub cursor # ?? factorize ??
{
my ($self, $def, $storage, $obj, $member) = @_;
my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db});
my $coll_id = $storage->export_object($obj);
my $coll_tid = $storage->alloc_table;
my $table = $def->{table};
my $item_tid = $cursor->{TARGET}->object->root_table;
my $coll_col = $def->{coll};
my $item_col = $def->{item};
my $slot_col = $def->{slot};
$cursor->{-coll_tid} = $coll_tid;
$cursor->{-coll_cols} = "t$coll_tid.$slot_col";
$cursor->{-coll_from} = "$table t$coll_tid";
$cursor->{-coll_where} = "t$coll_tid.$coll_col = $coll_id AND t$coll_tid.$item_col = t$item_tid.$storage->{schema}{sql}{id_col}";
$cursor->{-no_skip_read} = 1;
return $cursor;
}
# XXX - not reached by test suite
sub query_expr
{
my ($self, $obj, $members, $tid) = @_;
map { Tangram::Expr::Coll::FromMany->new($obj, $_); } values %$members;
}
sub remote_expr
{
my ($self, $obj, $tid) = @_;
Tangram::Expr::Coll::FromMany->new($obj, $self);
}
sub prefetch
{
my ($self, $storage, $def, $coll, $class, $member, $filter) = @_;
my $ritem = $storage->remote($def->{class});
# first retrieve the collection-side ids of all objects satisfying $filter
# empty the corresponding prefetch array
my $ids = $storage->my_select_data( cols => [ $coll->{id} ], filter => $filter );
my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref
while (my ($id) = $ids->fetchrow)
{
$prefetch->{$id} = {};
}
undef $ids;
# now fetch the items
my $cursor = Tangram::Cursor->new($storage, $ritem, $storage->{db});
my $includes = $coll->{$member}->includes($ritem);
# also retrieve collection-side id and index of elmt in sequence
$cursor->retrieve($coll->{id},
Tangram::Type::Number->expr("t$includes->{link_tid}.$def->{slot}") );
$cursor->select($filter ? $filter & $includes : $includes);
while (my $item = $cursor->current)
{
my ($coll_id, $slot) = $cursor->residue;
$prefetch->{$coll_id}{$slot} = $item;
$cursor->next;
}
return $prefetch;
}
$Tangram::Schema::TYPES{hash} = Tangram::Type::Hash::FromMany->new;
#---------------------------------------------------------------------
# Tangram::Type::Hash::FromMany->coldefs($cols, $members, $schema, $class, $tables)
#
# Setup column mappings for many to many indexed mappings (link
# table with string category)
#---------------------------------------------------------------------
sub coldefs
{
my ($self, $cols, $members, $schema, $class, $tables) = @_;
foreach my $member (values %$members)
{
$tables->{ $member->{table} }{COLS} =
{
$member->{coll} => $schema->{sql}{id},
$member->{item} => $schema->{sql}{id},
# XXX - hardcoded slot type
$member->{slot} => "VARCHAR(255) $schema->{sql}{default_null}"
};
}
}
1;
|