| 1 |
# (c) Sound Object Logic 2000-2001 |
| 2 |
|
| 3 |
use strict; |
| 4 |
|
| 5 |
package Tangram::Hash; |
| 6 |
|
| 7 |
use Tangram::AbstractHash; |
| 8 |
use vars qw(@ISA); |
| 9 |
@ISA = qw( Tangram::AbstractHash ); |
| 10 |
|
| 11 |
use Carp; |
| 12 |
|
| 13 |
sub reschema |
| 14 |
{ |
| 15 |
my ($self, $members, $class, $schema) = @_; |
| 16 |
|
| 17 |
foreach my $member (keys %$members) |
| 18 |
{ |
| 19 |
my $def = $members->{$member}; |
| 20 |
|
| 21 |
unless (ref($def)) |
| 22 |
{ |
| 23 |
$def = { class => $def }; |
| 24 |
$members->{$member} = $def; |
| 25 |
} |
| 26 |
|
| 27 |
$def->{table} ||= $schema->{normalize}->($def->{class} . "_$member", 'tablename'); |
| 28 |
$def->{coll} ||= 'coll'; |
| 29 |
$def->{item} ||= 'item'; |
| 30 |
$def->{slot} ||= 'slot'; |
| 31 |
$def->{quote} = !exists $def->{key_type} || $def->{key_type} eq 'string' ? "'" : ''; |
| 32 |
} |
| 33 |
|
| 34 |
return keys %$members; |
| 35 |
} |
| 36 |
|
| 37 |
sub defered_save { |
| 38 |
my ($self, $obj, $field, $storage) = @_; |
| 39 |
|
| 40 |
my $coll_id = $storage->export_object($obj); |
| 41 |
|
| 42 |
my ($table, $coll_col, $item_col, $slot_col) = @{ $self }{ qw( table coll item slot ) }; |
| 43 |
my $Q = $self->{quote}; |
| 44 |
|
| 45 |
my $coll = $obj->{$field}; |
| 46 |
|
| 47 |
my $old_state = $self->get_load_state($storage, $obj, $field) || {}; |
| 48 |
|
| 49 |
my %removed = %$old_state; |
| 50 |
delete @removed{ keys %$coll }; |
| 51 |
my @free = keys %removed; |
| 52 |
|
| 53 |
my %new_state; |
| 54 |
|
| 55 |
foreach my $slot (keys %$coll) |
| 56 |
{ |
| 57 |
my $item_id = $storage->export_object($coll->{$slot}); |
| 58 |
|
| 59 |
if (exists $old_state->{$slot}) |
| 60 |
{ |
| 61 |
# key already exists |
| 62 |
|
| 63 |
if ($item_id != $old_state->{$slot}) |
| 64 |
{ |
| 65 |
# val has changed |
| 66 |
$storage->sql_do( |
| 67 |
"UPDATE $table SET $item_col = $item_id WHERE $coll_col = $coll_id AND $slot_col = $Q$slot$Q" ); |
| 68 |
} |
| 69 |
} |
| 70 |
else |
| 71 |
{ |
| 72 |
# key does not exist |
| 73 |
|
| 74 |
if (@free) |
| 75 |
{ |
| 76 |
# recycle an existing line |
| 77 |
my $rslot = shift @free; |
| 78 |
$storage->sql_do( |
| 79 |
"UPDATE $table SET $slot_col = $Q$slot$Q, $item_col = $item_id WHERE $coll_col = $coll_id AND $slot_col = $Q$rslot$Q" ); |
| 80 |
} |
| 81 |
else |
| 82 |
{ |
| 83 |
# insert a new line |
| 84 |
$storage->sql_do( |
| 85 |
"INSERT INTO $table ($coll_col, $item_col, $slot_col) VALUES ($coll_id, $item_id, $Q$slot$Q)" ); |
| 86 |
} |
| 87 |
} |
| 88 |
|
| 89 |
$new_state{$slot} = $item_id; |
| 90 |
|
| 91 |
} # foreach my $slot (keys %$coll) |
| 92 |
|
| 93 |
# remove lines in excess |
| 94 |
|
| 95 |
if (@free) |
| 96 |
{ |
| 97 |
@free = map { "$Q$_$Q" } @free if $Q; |
| 98 |
$storage->sql_do( "DELETE FROM $table WHERE $coll_col = $coll_id AND $slot_col IN (@free)" ); |
| 99 |
} |
| 100 |
|
| 101 |
$self->set_load_state($storage, $obj, $field, \%new_state ); |
| 102 |
$storage->tx_on_rollback( sub { $self->set_load_state($storage, $obj, $field, $old_state) } ); |
| 103 |
} |
| 104 |
|
| 105 |
|
| 106 |
sub erase |
| 107 |
{ |
| 108 |
my ($self, $storage, $obj, $members, $coll_id) = @_; |
| 109 |
|
| 110 |
foreach my $member (keys %$members) |
| 111 |
{ |
| 112 |
my $def = $members->{$member}; |
| 113 |
|
| 114 |
my $table = $def->{table} || $def->{class} . "_$member"; |
| 115 |
my $coll_col = $def->{coll} || 'coll'; |
| 116 |
|
| 117 |
my $sql = "DELETE FROM $table WHERE $coll_col = $coll_id"; |
| 118 |
$storage->sql_do($sql); |
| 119 |
} |
| 120 |
} |
| 121 |
|
| 122 |
sub cursor # ?? factorize ?? |
| 123 |
{ |
| 124 |
my ($self, $def, $storage, $obj, $member) = @_; |
| 125 |
|
| 126 |
my $cursor = Tangram::CollCursor->new($storage, $def->{class}, $storage->{db}); |
| 127 |
|
| 128 |
my $coll_id = $storage->export_object($obj); |
| 129 |
my $coll_tid = $storage->alloc_table; |
| 130 |
my $table = $def->{table}; |
| 131 |
my $item_tid = $cursor->{TARGET}->object->root_table; |
| 132 |
my $coll_col = $def->{coll}; |
| 133 |
my $item_col = $def->{item}; |
| 134 |
my $slot_col = $def->{slot}; |
| 135 |
$cursor->{-coll_tid} = $coll_tid; |
| 136 |
$cursor->{-coll_cols} = "t$coll_tid.$slot_col"; |
| 137 |
$cursor->{-coll_from} = "$table t$coll_tid"; |
| 138 |
$cursor->{-coll_where} = "t$coll_tid.$coll_col = $coll_id AND t$coll_tid.$item_col = t$item_tid.id"; |
| 139 |
|
| 140 |
return $cursor; |
| 141 |
} |
| 142 |
|
| 143 |
sub query_expr |
| 144 |
{ |
| 145 |
my ($self, $obj, $members, $tid) = @_; |
| 146 |
map { Tangram::CollExpr->new($obj, $_); } values %$members; |
| 147 |
} |
| 148 |
|
| 149 |
sub remote_expr |
| 150 |
{ |
| 151 |
my ($self, $obj, $tid) = @_; |
| 152 |
Tangram::CollExpr->new($obj, $self); |
| 153 |
} |
| 154 |
|
| 155 |
sub prefetch |
| 156 |
{ |
| 157 |
q{ |
| 158 |
my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; |
| 159 |
|
| 160 |
my $ritem = $storage->remote($def->{class}); |
| 161 |
|
| 162 |
# first retrieve the collection-side ids of all objects satisfying $filter |
| 163 |
# empty the corresponding prefetch array |
| 164 |
|
| 165 |
my $ids = $storage->my_select_data( cols => [ $coll->{id} ], filter => $filter ); |
| 166 |
my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref |
| 167 |
|
| 168 |
while (my $id = $ids->fetchrow) |
| 169 |
{ |
| 170 |
$prefetch->{$id} = [] |
| 171 |
} |
| 172 |
|
| 173 |
undef $ids; |
| 174 |
|
| 175 |
# now fetch the items |
| 176 |
|
| 177 |
my $cursor = Tangram::Cursor->new($storage, $ritem, $storage->{db}); |
| 178 |
my $includes = $coll->{$member}->includes($ritem); |
| 179 |
|
| 180 |
# also retrieve collection-side id and index of elmt in sequence |
| 181 |
$cursor->retrieve($coll->{id}, |
| 182 |
Tangram::Number->expr("t$includes->{link_tid}.$def->{slot}" ) ); |
| 183 |
|
| 184 |
$cursor->select($filter ? $filter & $includes : $includes); |
| 185 |
|
| 186 |
while (my $item = $cursor->current) |
| 187 |
{ |
| 188 |
my ($coll_id, $slot) = $cursor->residue; |
| 189 |
$prefetch->{$coll_id}[$slot] = $item; |
| 190 |
$cursor->next; |
| 191 |
} |
| 192 |
|
| 193 |
} # skipped |
| 194 |
} |
| 195 |
|
| 196 |
$Tangram::Schema::TYPES{hash} = Tangram::Hash->new; |
| 197 |
|
| 198 |
1; |
Parent Directory
| 
Revision Log
