Line # Revision Author
1 8 ahitrov@rambler.ru package Contenido::Object;
2
3 # ----------------------------------------------------------------------------
4 # Класс Объект.
5 # Родительский класс для всех типов. Раз уж мы используем ООП, то давайте
6 # действительно его использовать.
7 #
8 # От него мы будем наследовать механизмы работы с директорией данных,
9 # механизмы работы с бинарными файлами и так далее...
10 # ----------------------------------------------------------------------------
11
12 use strict;
13 use warnings;
14 use locale;
15
16 use vars qw($VERSION $AUTOLOAD);
17 $VERSION = '4.1';
18
19 use Utils;
20 use Contenido::Globals;
21 113 ahitrov use Contenido::File;
22 8 ahitrov@rambler.ru use Data::Dumper;
23 217 ahitrov use Data::Recursive::Encode;
24 use JSON::XS;
25 8 ahitrov@rambler.ru
26 use DBD::Pg;
27 use Encode;
28 762 ahitrov use version;
29 8 ahitrov@rambler.ru
30 use SQL::ProtoTable;
31
32 217 ahitrov our $json_n = JSON::XS->new->utf8(0);
33 our $json_u = JSON::XS->new->utf8(1);
34
35 8 ahitrov@rambler.ru # required properties теперь берутся из свойств таблицы
36 sub required_properties {
37 my $self=shift;
38 my $class = ref($self) || $self;
39 if ($class->can('class_table')) {
40 return $self->class_table->required_properties();
41 } else {
42 $log->error("$class cannot method class_table");
43 return ();
44 }
45 }
46
47 sub extra_properties {
48 return ();
49 }
50
51 sub post_init {
52 return;
53 }
54
55 sub pre_store {
56 return 1;
57 }
58
59 sub post_store {
60 return 1;
61 }
62
63 sub post_finish_store {
64 return 1;
65 }
66
67 sub pre_delete {
68 return 1;
69 }
70
71 sub post_delete {
72 return 1;
73 }
74
75 sub pre_abort {
76 return 1;
77 }
78
79 sub t_abort {
80 my $self = shift;
81 $self->pre_abort();
82 return $self->keeper->t_abort();
83 }
84
85 sub new {
86 $log->error("Method 'new' cannot be called for class Contenido::Object");
87 die;
88 }
89
90 sub class_table {
91 $log->error("Method 'class_table' cannot be called for Contenido::Object");
92 die;
93 }
94
95 #обьявляем пустой DESTROY чтобы эта зараза в AUTOLOAD не попадала
96 sub DESTROY {}
97
98 #получение ключа в кеше по $object или по $class/$id
99 #can be overloaded in class
100 sub get_object_key {
101 my $self = shift;
102 return $self->class_table->_get_object_key($self, @_);
103 }
104
105 #получение ключа в кеше по $object или по $class/$unique
106 #can be overloaded in class
107 sub get_object_unique_key {
108 my $self = shift;
109 return $self->class_table->_get_object_unique_key($self, @_);
110 }
111
112 #скорость тут совершенно не критична... исполняется 1 раз на каждый класс
113 #??? возможно лучше сделать методы доступа к свойствам на этом этапе
114 sub class_init {
115 my $self = shift;
116 my $class = ref($self) || $self;
117
118 {
119 no strict 'refs';
120 return 1 if (${$class.'::class_init_done'});
121 use strict;
122 }
123
124 #инициализируем описатель таблицы
125 if ($class->can('class_table')) {
126 eval { SQL::ProtoTable->table_init($class->class_table) };
127 do { $log->error("Cannot initialise class $class!"); die } if ($@);
128 }
129
130 #валидация корректности класса (todo)
131 #$self->class_validate();
132
133 my $funct;
134
135 #начало текста функции инициализатора класса из базы
136 my $funct_begin = "
137 my (\$class, \$row, \$keeper, \$light) = \@_;
138 ";
139
140 my $funct_start_obj =' return bless({';
141 my $funct_end_obj = "}, '$class');
142 ";
143 my $funct_begin_if_light = '
144 if ($light) {';
145 my $funct_elsif_light = '
146 } else {';
147 my $funct_endif_light = '
148 }';
149
150 my $func_start_encode = '';
151 my $func_end_encode = '';
152
153 if ($state->db_encode_data) {
154 $func_start_encode = 'Encode::encode("'.$state->db_encode_data.'", ';
155 $func_end_encode = ', Encode::FB_HTMLCREF)';
156 }
157
158 390 ahitrov my @funct_default_fields = ("class=>'$class'", "keeper=>\$keeper", "__light=>\$light");
159 8 ahitrov@rambler.ru my @funct_exra_fields = ();
160
161 #те вещи которые надо заранее подсчитать при инициализации класса
162 my (%props, %attributes, @extra_fields, %virtual_fields, @structure);
163
164 my $pos = 0;
165 #последовательность reload: required_properties может быть перекрытым через add_properties который может быть далее перекрыт через extra_properties
166
167 foreach my $prop ($self->required_properties()) {
168 my $attr = $prop->{attr};
169 unless ($attr) {
170 $log->error("$class have wrong data in required_properties (no attr for field)");
171 next;
172 }
173 unless ($prop->{db_type} || $prop->{virtual}) {
174 $log->warning("$class with class table: ".$self->class_table()." property '$attr' missing db_type in table descriptor... can be incompatible with future versions!");
175 }
176
177 $props{$attr} = $prop;
178
179 push @structure, $prop;
180
181 #вообще с классом надо подумать... есть идея что для части таблиц класс поле не нужно... только место ест
182 next if ($attr eq 'class');
183
184 #поля которые идут в DB могут быть обьявлены ТОЛЬКО в required_properties
185 if (exists($prop->{db_field}) and $prop->{db_field}) {
186 $pos++;
187 #$DBD::Pg versions since 2.0.0 do it automatically
188 if ($DBD::Pg::VERSION=~/^1\./ and $prop->{db_type} and (($prop->{db_type} eq 'integer[]') or ($prop->{db_type} eq 'integer_ref[]'))) {
189 push @funct_default_fields, "$attr=>[(\$row->[$pos] and \$row->[$pos]=~/^{(\\d+(?:,\\d+)*)}\$/) ? split(/,/, \$1) : ()]";
190 } else {
191 push @funct_default_fields, "$attr=>$func_start_encode\$row->[$pos]$func_end_encode";
192 }
193 }
194
195 if ($prop->{db_type} and ($prop->{db_type} eq 'integer[]')) {
196 $attributes{$attr} = 'ARRAY';
197 } elsif($prop->{db_type} and ($prop->{db_type} eq 'integer_ref[]')) {
198 $attributes{$attr} = 'ARRAY_REF';
199 } else {
200 $attributes{$attr} = 'SCALAR';
201 }
202 }
203 push @funct_default_fields, "attributes=>\$${class}::attributes";
204
205 my $have_extra = $self->class_table->have_extra;
206 if ($have_extra) {
207 my @ap = $self->add_properties() if $self->can('add_properties');
208 #последовательность reload: required_properties может быть перекрытым через add_properties который может быть далее перекрыт через extra_properties
209 foreach my $prop (@ap, $self->extra_properties()) {
210 my $attr = $prop->{attr};
211 if (exists($props{$attr})) {
212 #reload code
213 $log->info("Reloaded property $attr for class $class") if ($DEBUG);
214 while ( my ($field, $value) = each(%$prop)) {
215 $props{$attr}->{$field} = $value;
216 }
217 } else {
218 $props{$attr} = $prop;
219 #если это был не overload то это новое extra поле
220 push @extra_fields, $attr;
221 push @structure, $prop;
222 $attributes{$attr} = 'SCALAR';
223 if ($prop->{virtual}) {
224 #выставляем что это вообще виртуальный атрибут
225 $virtual_fields{$attr} = 1;
226 } else {
227 #инициализируем из dump все кроме виртуальных свойств
228 392 ahitrov push @funct_exra_fields, "$attr=>(\$keeper->serialize_with eq 'json' ? (ref \$dump->{$attr} ? Data::Recursive::Encode->encode_utf8(\$dump->{$attr}) : Encode::encode('utf-8', \$dump->{$attr}, Encode::FB_HTMLCREF) ) : $func_start_encode\$dump->{$attr}$func_end_encode)";
229 8 ahitrov@rambler.ru }
230 }
231 }
232 }
233
234 $attributes{class} = 'SCALAR';
235
236 #если у обьекта есть extra_attributes надо бы вызвать restore_extras если не указан light
237 #наличие have_extra у таблицы не ведет к обязательному наличию extra_fields
238 if (@extra_fields) {
239 # --------------------------------------------------------------------------------------------
240 # Чтение из одного дампа в базе данных
241 # --------------------------------------------------------------------------------------------
242 my $funct_eval_dump .= '
243 217 ahitrov my $dump = $keeper->serialize_with eq \'json\' ? (Contenido::Object::eval_json(\\$row->[-1]) || {}) : Contenido::Object::eval_dump(\\$row->[-1]);
244 8 ahitrov@rambler.ru ';
245 $funct = $funct_begin.$funct_begin_if_light.$funct_start_obj.join(', ', @funct_default_fields).$funct_end_obj.$funct_elsif_light.$funct_eval_dump.$funct_start_obj.join(', ', (@funct_default_fields, @funct_exra_fields)).$funct_end_obj.$funct_endif_light;
246 } else {
247 $funct = $funct_begin.$funct_start_obj.join(', ', @funct_default_fields).$funct_end_obj;
248 }
249 217 ahitrov # warn "Restore function: [$funct]\n";
250 8 ahitrov@rambler.ru
251 create_method($class, 'init_from_db', $funct);
252
253 {
254 no strict 'refs';
255 ${$class.'::structure'} = \@structure;
256 ${$class.'::attributes'} = \%attributes;
257 ${$class.'::extra_fields'} = \@extra_fields;
258 ${$class.'::virtual_fields'} = \%virtual_fields;
259 ${$class.'::class_init_done'} = 1;
260 }
261 return 1;
262 }
263
264 # -------------------------------------------------------------------------------------------
265 # Сохраняет внешние свойства объекта в зависимости от выбранного способа...
266 # -------------------------------------------------------------------------------------------
267 sub store_extras {
268 my $self = shift;
269 my %opts = @_;
270 do {$log->error("Метод store_extras() можно вызывать только у объектов, но не классов\n"); die } unless ref($self);
271
272 do { $log->error("В объекте не определена ссылка на базу данных"); die } unless ref($self->keeper);
273 do { $log->error("Не задан режим сохранения данных (insert/update)"); die } if (($opts{mode} ne 'insert') && ($opts{mode} ne 'update'));
274 do { $log->error("Не задан идентификатор объекта (а должен быть задан в обязательном порядке)"); die } unless($self->id());
275
276 if ($self->keeper->store_method() eq 'sqldump') {
277 my $extra_table=$self->class_table->extra_table;
278 do { $log->error("No extra table for class $self->{class}"); die } unless ($extra_table);
279 if ($opts{mode} eq 'insert') {
280 $self->keeper->TSQL->do("INSERT INTO $extra_table (id, data) VALUES (?, ?)", {}, $self->id(), $self->_create_extra_dump()) || $self->t_abort();
281 } else {
282 $self->keeper->TSQL->do("UPDATE $extra_table SET data=? WHERE id=?", {}, $self->_create_extra_dump(), $self->id()) || $self->t_abort();
283 }
284
285 } elsif ($self->keeper->store_method() eq 'toast') {
286 my $table = $self->class_table->db_table;
287 do { $log->error("There no db_table for class $self->{class}"); die } unless ($table);
288 $self->keeper->TSQL->do("UPDATE $table SET data=? WHERE id=?", {}, $self->_create_extra_dump(), $self->id()) || $self->t_abort();
289
290 } else {
291 $log->error("Метод сохранения объектов задан неверно! Возможные значения - TOAST, SQLDUMP");
292 die;
293 }
294
295 return 1;
296 }
297
298
299 sub _create_extra_dump {
300 my $self = shift;
301
302 do { $log->error("Метод _create_extra_dump можно вызывать только у объектов, но не классов"); die } unless ref($self);
303
304 my $class_table = $self->class_table;
305 return undef unless ($class_table and $class_table->have_extra);
306
307 my $extra_fields = [];
308 my $virtual_fields = {};
309 217 ahitrov
310 if ( $self->keeper->serialize_with eq 'json' ) {
311 8 ahitrov@rambler.ru no strict 'refs';
312 #пропускаем virtual attributes
313 #да я знаю что так писать нельзя но блин крута как смотрится
314 $extra_fields = ${$self->{class}.'::extra_fields'};
315 $virtual_fields = ${$self->{class}.'::virtual_fields'};
316 #надо использовать все extra поля кроме тех что находятся в virtual_fields списке
317 762 ahitrov warn "DBD-Pg: ".$DBD::Pg::VERSION.", Perl version: ".$]."\n" if $DEBUG;
318 8 ahitrov@rambler.ru if ($state->db_encode_data) {
319 217 ahitrov return Encode::decode('utf-8', $json_n->encode ({map { $_=> Encode::decode($state->db_encode_data, $self->{$_}, Encode::FB_HTMLCREF) } grep { !$virtual_fields->{$_} && (defined $self->{$_}) } @$extra_fields}));
320 762 ahitrov } elsif ( version->parse($DBD::Pg::VERSION) >= '3' && $] < '5.026' ) {
321 724 ahitrov return Encode::decode('utf-8', $json_n->encode ({map { $_=>$self->{$_} } grep { !$virtual_fields->{$_} && (defined $self->{$_}) } @$extra_fields}));
322 217 ahitrov } else {
323 725 ahitrov return $json_n->encode( {map { $_=>$self->{$_} } grep { !$virtual_fields->{$_} && (defined $self->{$_}) } @$extra_fields} );
324 217 ahitrov }
325 } else {
326 no strict 'refs';
327 #пропускаем virtual attributes
328 #да я знаю что так писать нельзя но блин крута как смотрится
329 $extra_fields = ${$self->{class}.'::extra_fields'};
330 $virtual_fields = ${$self->{class}.'::virtual_fields'};
331 #надо использовать все extra поля кроме тех что находятся в virtual_fields списке
332 local $Data::Dumper::Indent = 0;
333 if ($state->db_encode_data) {
334 8 ahitrov@rambler.ru return Data::Dumper::Dumper({map { $_=> Encode::decode($state->db_encode_data, $self->{$_}, Encode::FB_HTMLCREF) } grep { !$virtual_fields->{$_} && (defined $self->{$_}) } @$extra_fields});
335 762 ahitrov } elsif ( version->parse($DBD::Pg::VERSION) >= '3' && $] < '5.026' ) {
336 583 ahitrov return Encode::decode( 'utf-8', Data::Dumper::Dumper({map { $_=>$self->{$_} } grep { !$virtual_fields->{$_} && (defined $self->{$_}) } @$extra_fields}) );
337 8 ahitrov@rambler.ru } else {
338 return Data::Dumper::Dumper({map { $_=>$self->{$_} } grep { !$virtual_fields->{$_} && (defined $self->{$_}) } @$extra_fields});
339 }
340 }
341 }
342
343 # -------------------------------------------------------------------------------------------
344 # Считывает внешние свойства объекта в зависимости от выбранного способа...
345 # -------------------------------------------------------------------------------------------
346 sub restore_extras {
347 my ($self, $row) = @_;
348
349 do { $log->error("Метод restore_extras() можно вызывать только у объектов, но не классов"); die } unless ref($self);
350
351 my $extra_fields;
352 {
353 no strict 'refs';
354 $extra_fields = ${$self->{class}.'::extra_fields'};
355 }
356
357 if (@$extra_fields) {
358 if (($Contenido::Globals::store_method eq 'toast') or ($Contenido::Globals::store_method eq 'sqldump')) {
359 # --------------------------------------------------------------------------------------------
360 # Чтение из одного дампа в базе данных
361 # --------------------------------------------------------------------------------------------
362 217 ahitrov my $dump_ = $self->keeper->serialize_with eq 'json' ? eval_json(\$row->[-1]) : eval_dump(\$row->[-1]);
363 8 ahitrov@rambler.ru if ($dump_) {
364 foreach (@$extra_fields) {
365 $self->{$_} = $dump_->{$_};
366 }
367 }
368 } else {
369 $log->error("Метод сохранения объектов задан неверно! Возможные значения - TOAST, SQLDUMP, SINGLE, DUMP");
370 die;
371 }
372 }
373 }
374
375 217 ahitrov sub _serialize {
376 my $self = shift;
377 my $data = shift;
378 if ( $self->keeper->serialize_with eq 'json' ) {
379 476 ahitrov return $json_n->encode(ref $data ? $data : {});
380 217 ahitrov } else {
381 local $Data::Dumper::Indent = 0;
382 return Data::Dumper::Dumper($data);
383 }
384 }
385
386 8 ahitrov@rambler.ru # ----------------------------------------------------------------------------
387 # Выбирает хеш из перл-дампа по атрибуту
388 # Пример:
389 # my $pics_hashe = $doc->get_data('images');
390 # ----------------------------------------------------------------------------
391 sub get_data {
392 my $self = shift;
393 my $attr = shift;
394 217 ahitrov my $encode = shift;
395 596 ahitrov if ( ref $self->$attr ) {
396 return $self->$attr;
397 } else {
398 my $data = $self->keeper->serialize_with eq 'json' ? ( $encode ? Data::Recursive::Encode->encode_utf8(eval_json(\$self->{$attr})) : eval_json(\$self->{$attr}) ) : eval_dump(\$self->{$attr});
399 return ($data || {});
400 }
401 8 ahitrov@rambler.ru }
402
403 # ----------------------------------------------------------------------------
404 # Выбирает картинку из обьекта по ее атрибуту
405 # Возвращает обьект типа Contenido::Image
406 #
407 # Пример:
408 # my $pic = $doc->get_pic('top_image');
409 #
410 # ----------------------------------------------------------------------------
411 sub get_pic {
412 my $self = shift;
413 my $attr = shift;
414
415 Contenido::Image->new (
416 217 ahitrov img => $self->get_data($attr, 'encode'),
417 8 ahitrov@rambler.ru attr => $attr,
418 );
419 }
420
421 # ----------------------------------------------------------------------------
422 # Выбирает картинки из обьекта по атрибуту их хранилища
423 # Возвращает массив обьектов типа Contenido::Image
424 #
425 # Пример:
426 # my @pics = $doc->get_pics('images', {
427 # order => 'reverse', # порядок сортировки по ключам ('reverse' ,'asis', по умолчанию - 'direct')
428 # keys => [3..12, 1..2], # диапазон ключей
429 # });
430 #
431 # ----------------------------------------------------------------------------
432 sub get_pics {
433 my $self = shift;
434 my $attr = shift;
435 my %args = ref $_[0] ? %{$_[0]} : @_;
436 217 ahitrov my $pics = $self->get_data($attr, 'encode');
437 8 ahitrov@rambler.ru
438 # Дефолты
439 $args{order} ||= 'direct';
440
441 # выясняем ключики нужных нам картинок...
442 my @keys = ref $args{keys} ne 'ARRAY' ? grep {s/\D+//, /^\d+$/} keys %{$pics} : @{$args{keys}};
443
444 my $prefix = 'image_'; # а надо бы, чтоб так: my $prefix = $attr.'_';
445
446 map { Contenido::Image->new (
447 img => $pics->{$prefix.$_},
448 attr => $prefix.$_,
449 group => $attr,
450 key => $_,
451 )} sort { $args{order} eq 'asis' ? 1 : $args{order} ne 'reverse' ? $a <=> $b : $b <=> $a } @keys;
452 }
453
454 sub _get_sql {
455 my ($self,%opts)=@_;
456
457 #детект класса таблицы по которой работаем
458 my $table = $self->_get_table(%opts);
459 unless ($table) {
460 $log->error("Не могу получить таблицу запроса");
461 return;
462 }
463
464 my ($query, $binds) = $table->generate_sql(%opts);
465 my @binds = ();
466
467 762 ahitrov warn "DBD-Pg: ".$DBD::Pg::VERSION.", Perl version: ".$]."\n" if $DEBUG;
468 8 ahitrov@rambler.ru if ($state->db_encode_data) {
469 foreach my $i (0..$#{$binds}) {
470 582 ahitrov if ( ref $binds->[$i] ) {
471 $binds->[$i] = Data::Recursive::Encode->decode($state->db_encode_data, $binds->[$i], Encode::FB_HTMLCREF);
472 } else {
473 $binds->[$i] = Encode::decode($state->db_encode_data, $binds->[$i], Encode::FB_HTMLCREF);
474 }
475 8 ahitrov@rambler.ru }
476 763 ahitrov } elsif ( version->parse($DBD::Pg::VERSION) > version->parse('3') && $] < '5.026' ) {
477 567 ahitrov foreach my $i (0..$#{$binds}) {
478 582 ahitrov if ( ref $binds->[$i] ) {
479 $binds->[$i] = Data::Recursive::Encode->decode_utf8($binds->[$i]);
480 } else {
481 $binds->[$i] = Encode::decode('utf-8', $binds->[$i], Encode::FB_HTMLCREF);
482 }
483 567 ahitrov }
484 8 ahitrov@rambler.ru }
485
486 return $query, $binds;
487 }
488
489 # Формат использования:
490 # $document->store()
491 #
492 # Если $id задан то мы считаем, что этот объект в базе есть. Если
493 # не задан, то мы считаем, что этого объекта в базе нет и создаем его.
494 778 ahitrov # Если необходимо взять контроль над INSERT-UPDATE, следует передать
495 # hashref с параметром mode => 'update|insert'
496 8 ahitrov@rambler.ru # ----------------------------------------------------------------------------
497 sub store {
498 my $self = shift;
499 do { $log->error("Метод store() можно вызывать только у объектов, но не классов"); die } unless ref($self);
500
501 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($self->keeper);
502
503 return undef if ($self->keeper->state->readonly());
504
505 778 ahitrov my $params = shift // {};
506 779 ahitrov my $store_mode = lc($params->{mode} || '');
507 778 ahitrov $store_mode = '' if $store_mode && !($store_mode eq 'insert' || $store_mode eq 'update');
508
509 8 ahitrov@rambler.ru $self->keeper->t_connect() || do { $self->keeper->error(); return undef; };
510 $self->{status} ||= 0; # Значение статуса по умолчанию = 0
511
512 unless ($self->pre_store()) {
513 $log->notice("pre_store call failed!");
514 return undef;
515 }
516
517 my (@fields, @values, @default_pairs, @default_fields, @default_values, @binary_fields);
518
519 foreach ($self->required_properties()) {
520
521 my $value = $self->{$_->{attr}};
522 217 ahitrov if ( exists $_->{db_field} && $_->{db_field} ) {
523 $value = undef if (defined($value) and $value eq '') and (lc($_->{db_type}) eq 'float' or lc($_->{db_type} eq 'integer'));
524 $value = undef if lc $_->{db_type} eq 'integer[]' && ref $value ne 'ARRAY';
525 $value = undef if lc $_->{db_type} eq 'integer_ref[]' && ref $value ne 'ARRAY';
526 }
527 8 ahitrov@rambler.ru
528 779 ahitrov # выставить id, если у документа есть id и установлен режим 'insert'
529 if ($_->{db_field} eq 'id' && $store_mode eq 'insert' && $self->id()) {
530 push @fields, $_->{db_field};
531 push @values, $value;
532 8 ahitrov@rambler.ru
533 779 ahitrov # пропустить readonly, если у документа уже есть id
534 } elsif ($store_mode ne 'insert' && $self->id() and $_->{readonly}) {
535
536
537 # нет поля в базе у атрибута
538 8 ahitrov@rambler.ru } elsif (!$_->{db_field}) {
539
540 779 ahitrov # установка default если оно есть и стоит авто или нет значения у поля
541 8 ahitrov@rambler.ru } elsif (defined($_->{default}) and ($_->{auto} or !defined($value))) {
542 push @default_fields, $_->{db_field};
543 push @default_values, $_->{default};
544 push @default_pairs, "$_->{db_field}=$_->{default}";
545
546 779 ahitrov # пропустить auto без default
547 8 ahitrov@rambler.ru } elsif ($_->{auto}) {
548
549 #установка валидных полей
550 } elsif (defined($value)) {
551 push @fields, $_->{db_field};
552 if ($_->{db_type} eq 'integer[]') {
553 push @values, '{'.join(',', grep { $_ } @$value).'}';
554 } elsif ($_->{db_type} eq 'integer_ref[]') {
555 push @values, '{'.join(',', grep { $_ } @$value).'}';
556 } else {
557 #some special work for bytea column type
558 push @binary_fields, scalar(@fields) if ($_->{db_type} eq 'bytea');
559 if ($state->db_encode_data) {
560 push @values, Encode::decode($state->db_encode_data, $value, Encode::FB_HTMLCREF);
561 723 ahitrov } elsif ($DBD::Pg::VERSION >= '3' && $] < '5.026') {
562 742 ahitrov # warn "Decode for ".$DBD::Pg::VERSION." and $]\n";
563 567 ahitrov push @values, Encode::decode('utf-8', $value, Encode::FB_HTMLCREF);
564 8 ahitrov@rambler.ru } else {
565 push @values, $value;
566 }
567 }
568
569 #undef to NULL or empty array
570 } else {
571 push @default_fields, $_->{db_field};
572 push @default_values, 'NULL';
573 push @default_pairs, "$_->{db_field}=NULL";
574 }
575 }
576
577 #если использется toast то загоняется за 1 sql запрос и extra тоже
578 390 ahitrov if (($self->keeper->store_method() eq 'toast') and $self->class_table->have_extra and !$self->{__light}) {
579 8 ahitrov@rambler.ru push @fields, 'data';
580 push @values, $self->_create_extra_dump();
581 }
582
583
584 my $values_string = '';
585 778 ahitrov my $mode = $store_mode || 'update';
586 if ($mode eq 'update' && $self->id()) {
587 8 ahitrov@rambler.ru if (@fields) {
588 $values_string = join(' = ?, ', @fields).' = ?';
589 $values_string .= ', '.join(', ', @default_pairs) if (@default_pairs);
590 #нет обычных значений работаем только по @default_pairs
591 } else {
592 $values_string = join(', ', @default_pairs) if (@default_pairs);
593 }
594 my $sql='UPDATE '.$self->class_table->db_table.' SET '.$values_string." WHERE ".$self->class_table()->id_field()." = ?";
595 779 ahitrov warn "$sql\n" if $DEBUG;
596 8 ahitrov@rambler.ru
597 my $sth=$self->keeper->TSQL->prepare_cached($sql, {}, 1) || return $self->t_abort();
598 #settin special escape for bytea column type!!!
599 foreach (@binary_fields) {
600 $sth->bind_param($_, undef, {pg_type => DBD::Pg::PG_BYTEA});
601 }
602 725 ahitrov # warn Data::Dumper::Dumper(\@values) if $DEBUG;
603 8 ahitrov@rambler.ru unless ($sth->execute(@values, $self->{id})) {
604 728 ahitrov $log->error("DBI execute error on $sql\n".Data::Dumper::Dumper( $DBD::Pg::VERSION >= '3' && $] < '5.026' ? Data::Recursive::Encode->encode_utf8( \@values ) : \@values ));
605 8 ahitrov@rambler.ru $sth->finish();
606 return $self->t_abort();
607 }
608 $sth->finish();
609
610 390 ahitrov if (($self->keeper->store_method() ne 'toast') and $self->class_table->have_extra and !$self->{__light}) {
611 8 ahitrov@rambler.ru $self->store_extras(mode => $mode) || return $self->t_abort();
612 }
613
614 } else {
615 $mode = 'insert';
616 if (@fields) {
617 $values_string = '?, 'x(scalar (@fields)-1).'?';
618 $values_string .= ', '.join(', ', @default_values) if (@default_values);
619 #нет обычных значений работаем только по @default_pairs
620 } else {
621 $values_string = join(', ', @default_values) if (@default_values);
622 }
623 my $sql='INSERT INTO '.$self->class_table->db_table.' ('.join(', ', (@fields, @default_fields)).') VALUES ('.$values_string.')';
624 779 ahitrov warn "$sql\n" if $DEBUG;
625 8 ahitrov@rambler.ru
626 my $sth=$self->keeper->TSQL->prepare_cached($sql, {}, 1) || return $self->t_abort();
627 #settin special escape for bytea column type!!!
628 foreach (@binary_fields) {
629 $sth->bind_param($_, undef, {pg_type => DBD::Pg::PG_BYTEA});
630 }
631 unless ($sth->execute(@values)) {
632 728 ahitrov $log->error("DBI execute error on $sql\n".Data::Dumper::Dumper( $DBD::Pg::VERSION >= '3' && $] < '5.026' ? Data::Recursive::Encode->encode_utf8( \@values ) : \@values ));
633 8 ahitrov@rambler.ru $sth->finish();
634 return $self->t_abort();
635 }
636 $sth->finish();
637
638 778 ahitrov unless ( $self->id ) {
639 my $id = $self->keeper->TSQL->selectrow_array("SELECT currval('".$self->class_table->db_id_sequence()."')");
640 $self->id($id);
641 return $self->t_abort("Документу присвоен неверный идентификатор") if (! defined($self->{id}) || ($self->{id} <= 0));
642 }
643 8 ahitrov@rambler.ru
644 390 ahitrov if (($self->keeper->store_method() ne 'toast') and $self->class_table->have_extra and !$self->{__light}) {
645 8 ahitrov@rambler.ru $self->store_extras(mode => $mode) || return $self->t_abort();
646 }
647
648 }
649
650 $self->post_store(mode => $mode);
651
652 $self->keeper->t_finish();
653
654 $self->post_finish_store();
655
656 $self->drop_cache($mode) if ($self->keeper->state()->memcached_enable());
657
658 return 1;
659 }
660
661 # ----------------------------------------------------------------------------
662 # Метод delete() для удаления объекта из базы данных.
663 #
664 # Формат использования:
665 # $document->delete()
666 # ----------------------------------------------------------------------------
667 sub delete {
668 my $self = shift;
669 my (%opts) = @_;
670 do { $log->error("Метод delete() можно вызывать только у объектов, но не классов"); die } unless ref($self);
671
672 return undef if ($self->keeper->state->readonly());
673
674 unless ($self->pre_delete()) {
675 $log->error("pre_delete call failed!");
676 return undef;
677 }
678
679 my $keeper = $self->keeper;
680 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($keeper);
681
682 390 ahitrov my $delete_attachments = exists $opts{attachments} ? $opts{attachments} : 1;
683 if ( $delete_attachments ) {
684 8 ahitrov@rambler.ru my @props = $self->structure();
685 if ( @props ) {
686 347 ahitrov @props = grep { $_->{type} =~ /^(image|images|multimedia_new|multimedia_multi)$/ } @props;
687 8 ahitrov@rambler.ru foreach my $prop ( @props ) {
688 my $att = $self->get_image($prop->{attr});
689 if ( $prop->{type} eq 'image' ) {
690 if ( ref $att && exists $att->{filename} && $att->{filename} ) {
691 Contenido::File::remove( $att->{filename} );
692 }
693 55 ahitrov@rambler.ru if ( exists $att->{mini} && ref $att->{mini} eq 'HASH' ) {
694 Contenido::File::remove( $att->{mini}{filename} ) if exists $att->{mini}{filename};
695 foreach my $val ( values %{ $att->{mini} } ) {
696 if ( ref $val && exists $val->{filename} && $val->{filename} && ($val->{filename} ne $att->{mini}{filename}) ) {
697 Contenido::File::remove( $val->{filename} );
698 8 ahitrov@rambler.ru }
699 }
700 }
701
702 } elsif ( $prop->{type} eq 'images' ) {
703 for ( 1..100 ) {
704 next unless exists $att->{"image_$_"};
705 my $img = $att->{"image_$_"};
706 if ( ref $img && exists $img->{filename} && $img->{filename} ) {
707 Contenido::File::remove( $img->{filename} );
708 }
709 55 ahitrov@rambler.ru if ( exists $img->{mini} && ref $img->{mini} eq 'HASH' ) {
710 Contenido::File::remove( $img->{mini}{filename} ) if exists $img->{mini}{filename};
711 foreach my $val ( values %{ $img->{mini} } ) {
712 if ( ref $val && exists $val->{filename} && $val->{filename} && ($val->{filename} ne $img->{mini}{filename}) ) {
713 Contenido::File::remove( $val->{filename} );
714 8 ahitrov@rambler.ru }
715 }
716 }
717 }
718 } elsif ( $prop->{type} eq 'multimedia_new' ) {
719 if ( ref $att && exists $att->{filename} && $att->{filename} ) {
720 Contenido::File::remove( $att->{filename} );
721 }
722 347 ahitrov } elsif ( $prop->{type} eq 'multimedia_multi' ) {
723 for ( 1..100 ) {
724 next unless exists $att->{"file_$_"};
725 my $file = $att->{"file_$_"};
726 if ( ref $file && exists $file->{filename} && $file->{filename} ) {
727 Contenido::File::remove( $file->{filename} );
728 }
729 }
730 8 ahitrov@rambler.ru }
731 }
732 }
733 }
734 45 ahitrov@rambler.ru do { $log->warning("Вызов метода delete() без указания идентификатора для удаления"); return undef }
735 55 ahitrov@rambler.ru unless ($self->{id});
736 8 ahitrov@rambler.ru $keeper->t_connect() || do { $keeper->error(); return undef; };
737 $keeper->TSQL->do("DELETE FROM ".$self->class_table->db_table." WHERE id = ?", {}, $self->id) || return $self->t_abort();
738
739 # Удаление связей этого документа с другими документами...
740 my %document_links;
741 if ( $keeper->state->{available_links} && ref $keeper->state->{available_links} eq 'ARRAY' ) {
742 foreach my $classlink ( @{ $keeper->state->{available_links} } ) {
743 my $sources = $classlink->available_sources;
744 if ( ref $sources eq 'ARRAY' && @$sources ) {
745 $document_links{$classlink->class_table->db_table}{source} = 1 if grep { $self->class eq $_ } @$sources;
746 }
747 my $dests = $classlink->available_destinations;
748 if ( ref $dests eq 'ARRAY' && @$dests ) {
749 45 ahitrov@rambler.ru $document_links{$classlink->class_table->db_table}{dest} = 1 if grep { $self->class eq $_ } @$dests;
750 8 ahitrov@rambler.ru }
751 }
752 foreach my $tablename ( keys %document_links ) {
753 my (@wheres, @values);
754 if ( exists $document_links{$tablename}{source} ) {
755 push @wheres, "(source_id = ? AND source_class = ?)";
756 push @values, ( $self->id, $self->class );
757 }
758 if ( exists $document_links{$tablename}{dest} ) {
759 push @wheres, "(dest_id = ? AND dest_class = ?)";
760 push @values, ( $self->id, $self->class );
761 }
762 my $request = "DELETE FROM $tablename WHERE ".join (' OR ', @wheres);
763 warn "DELETE LINKS. Request: [$request]\n" if $DEBUG;
764 warn "Values: [".join(', ', @values)."]\n" if $DEBUG;
765 $keeper->TSQL->do($request, {}, @values) || return $self->t_abort();
766 }
767 } else {
768 $keeper->TSQL->do("DELETE FROM links WHERE source_id = ? AND source_class = ? ", {}, $self->id, $self->class) || return $self->t_abort();
769 $keeper->TSQL->do("DELETE FROM links WHERE dest_id = ? AND dest_class = ? ", {}, $self->id, $self->class) || return $self->t_abort();
770 }
771 $keeper->t_finish();
772
773 $self->post_delete();
774
775 $self->drop_cache('delete') if ($keeper->state()->memcached_enable());
776
777 return 1;
778 }
779
780 # ----------------------------------------------------------------------------
781 # Метод links() возвращает массив объектов типа Contenido::Link
782 #
783 # Формат использования:
784 # $document->links([класс])
785 # ----------------------------------------------------------------------------
786 sub links {
787 my ($self, $lclass, $direction, %opts) = @_;
788 do { $log->error("Метод ->links() можно вызывать только у объектов, но не классов"); die } unless ref($self);
789
790 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($self->keeper);
791
792 do { $log->warning("Вызов метода ->links() без указания идентификатора сообщения-источника"); return () } unless ($self->id() > 0);
793
794 my $check = defined $direction ? 'dest_id' : 'source_id';
795
796 $opts{$check} = $self->id();
797
798 if (defined($lclass) && (length($lclass) > 0)) {
799 55 ahitrov@rambler.ru $opts{class} = $lclass;
800 8 ahitrov@rambler.ru }
801
802 my @links = $self->keeper->get_links(%opts);
803
804 $self->{links} = \@links;
805 return @links;
806 }
807
808
809 sub linked_to {
810 my ($self, $lclass) = @_;
811 $self->links($lclass, 1);
812 }
813
814
815 # ----------------------------------------------------------------------------
816 # Установка связи. Должен быть обязательно задан класс...
817 # В качестве source_id выступает идентификатор объекта, в качестве $dest_id -
818 # заданный.
819 #
820 # Формат использования:
821 # $document->set_link($lclass, $dest_id)
822 #
823 # Проверки не производится - у сообщения может быть несколько одинаковых
824 # связей.
825 # ----------------------------------------------------------------------------
826 sub set_link {
827 my ($self, $lclass, $dest_id, $dest_class, @opts) = @_;
828 do { $log->error("Метод ->set_link() вызван с неправильным кол-вом агрументов"); die } if @opts % 2;
829 do { $log->error("Метод ->set_link() можно вызывать только у объектов, но не классов"); die } unless ref($self);
830 my %opts = @opts;
831
832 return undef if ($self->keeper->state->readonly());
833
834 do { $log->warning("Вызов метода ->set_link() без указания идентификатора сообщения-источника"); return undef } unless ($self->id() > 0);
835 do { $log->warning("Вызов метода ->set_link() без указания идентификатора сообщения-цели"); return undef } unless ($dest_id >= 0);
836 115 ahitrov do { $log->warning("Вызов метода ->set_link() без указания класса связи"); } unless defined($lclass) && length($lclass);
837 8 ahitrov@rambler.ru
838 # Создаем объект связи...
839 my $link = $lclass->new($self->keeper);
840
841 $link->dest_id($dest_id);
842 $link->dest_class($dest_class);
843
844 $link->status(1);
845
846 $link->source_id($self->id());
847 $link->source_class($self->class());
848
849 while (my ($k,$v) = each %opts) {
850 55 ahitrov@rambler.ru $link->{$k} = $v;
851 8 ahitrov@rambler.ru }
852
853 if ($link->store())
854 {
855 55 ahitrov@rambler.ru return $link->id;
856 8 ahitrov@rambler.ru } else {
857 55 ahitrov@rambler.ru return undef;
858 8 ahitrov@rambler.ru }
859 }
860
861 # -------------------------------------------------------------------
862 # Превращает объект в проблессенный хэш.
863 #
864 sub prepare_for_cache {
865 my $self = shift;
866
867 do { $log->error("Метод ->prepare_for_cache() можно вызывать только у объектов, но не классов"); die } unless ref($self);
868
869 my $hash = {};
870
871 foreach ( $self->structure() ) {
872 55 ahitrov@rambler.ru $hash->{$_->{attr}} = $self->{$_->{attr}} if defined $self->{$_->{attr}};
873 8 ahitrov@rambler.ru }
874 bless $hash, $self->class();
875 return $hash;
876 }
877
878 # -------------------------------------------------------------------
879 # Восстанавливает полноценный объект по проблессенному хэшу.
880 # Хэш при этом превращается в полноценный объект.
881 # -------------------------------------------------------------------
882 sub recover_from_cache {
883 my $self = shift;
884 my $keeper = shift;
885
886 do { $log->error("Метод ->recover_from_cache() можно вызывать только у объектов, но не классов"); die } unless ref($self);
887 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($keeper);
888
889 #не нужен тут bless очередной... 100% если уж попали в обьектный метод то он явно имеет класс нужный
890 $self->init();
891 $self->keeper($keeper);
892
893 return 1;
894 }
895
896 # -------------------------------------------------------------------
897 # Возвращает хэш:
898 # {действие1 => [кэш1, кэш2, ...], действие2 => [кэш1, кэш2, ...], ...}
899 # Т.е. для каждого действия задается список имен ключей в кэше,
900 # которые надо удалить.
901 # Дефолтные значени действий: insert, update, delete
902 # Для более сложной логики работы этот метод должен быть переопределен
903 # в классе самого объекта
904 #
905 sub dependencies {
906 my ($self, $mode) = @_;
907
908 my @keys = ($self->get_object_key,);
909 my $object_unique_key = $self->get_object_unique_key;
910 push @keys, $object_unique_key if defined $object_unique_key;
911
912 return
913 ($mode eq 'delete') || ($mode eq 'insert') || ($mode eq 'update')
914 ? \@keys
915 : [];
916 }
917
918 # -------------------------------------------------------------------
919 # Удаляет из кэша ключи, заданные при помощи dependencies().
920 # Пример вызова:
921 # $group->drop_cache('update');
922 #
923 sub drop_cache {
924 my $self = shift;
925 my $mode = shift;
926
927 do { $log->error("Метод ->drop_cache() можно вызывать только у объектов, но не классов"); die } unless ref($self);
928
929 my $keeper = $self->keeper;
930 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($keeper);
931
932 my $dependencies = $self->dependencies($mode, @_);
933
934 my @not_deleted = ();
935 if ( defined($dependencies) && (ref($dependencies) eq 'ARRAY') ) {
936 for (@$dependencies) {
937 my $res = $self->keeper->MEMD ? $self->keeper->MEMD->delete($_) : undef;
938 push @not_deleted, $_ unless $res;
939 $keeper->MEMD->delete($_) if ($keeper->MEMD);
940 }
941 }
942 return @not_deleted;
943 }
944
945
946 sub keeper {
947 my $self = shift;
948 my $project_keeper = shift;
949
950 do { $log->error("Метод keeper() можно вызывать только у объектов, но не классов"); die } unless ref($self);
951
952 if ($project_keeper && ref $project_keeper) {
953 $self->{keeper} = $project_keeper;
954 return $project_keeper;
955 }
956 return $self->{keeper} && ref $self->{keeper} ? $self->{keeper} : $keeper;
957 }
958
959 #делаем затычку для init_from_db чтобы проинициализировать класс если надо
960 sub init_from_db {
961 my $self = shift;
962
963 my $class = ref($self) || $self;
964
965 #защита от бесконечной рекурсии если class_init не срабатывает
966 if (defined($_[-1]) and ($_[-1] eq 'RECURSIVE CALL FLAG!')) {
967 do { $log->error("$class cannot be initialized (->class_init dont work) (recursive call) !!!"); die };
968 }
969
970 #если клас каким то странным образом все еще не проинициализирован то попробовать проинициализировать
971 #только инициализация метода init_from_db допускает не ref на входе
972 if ($class and $class->isa('Contenido::Object')) {
973 no strict 'refs';
974 if (${$class.'::class_init_done'}) {
975 do { $log->error("$class already initialized but DONT HAVE init_from_db method!!!"); die };
976 } else {
977 if ($self->class_init()) {
978 return $self->init_from_db(@_, 'RECURSIVE CALL FLAG!');
979 } else {
980 do { $log->error("$class cannot be initialized (->class_init dont work) !!!"); die };
981 }
982 }
983 } else {
984 do { $log->error("$class cannot be initialized (not Contenido::Object child class) !!!"); die };
985 }
986 }
987
988 # ----------------------------------------------------------------------------
989 # Это умный AUTOLOAD. Ловит методов для установки/чтения полей...
990 # Версия 1.0
991 # теперь он герерирует необходимый метод доступу если надо
992 # ----------------------------------------------------------------------------
993 sub AUTOLOAD {
994 my $self = shift;
995 my $attribute = $AUTOLOAD;
996
997 $log->info("$self calling AUTOLOAD method: $attribute") if ($DEBUG_CORE);
998
999 $attribute=~s/^.*:://;
1000
1001 my $class = ref($self);
1002 unless ($class and $class->isa('Contenido::Object')) {
1003
1004 my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
1005 my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
1006 my ($package, $filename, $line) = caller;
1007
1008 $log->warning("Wrong AUTOLOAD call with self='$self'/class='$class' and method '$attribute' called from '$package/$filename/$line' ".($mason_file ? "called from $mason_file" : '')."\n".Data::Dumper::Dumper($self));
1009 if (wantarray) { return (); } else { return undef; }
1010 }
1011
1012 #вообщето сюда было бы не плохо засунуть инициализацию класса если уж мы каким то хреном сюда попали для неинициализированного класса
1013 {
1014 no strict 'refs';
1015 unless (${$class.'::class_init_done'}) {
1016 my ($package, $filename, $line) = caller;
1017 $log->error("AUTOLOAD called method '$attribute' for not initialised class ($class) from '$package/$filename/$line'");
1018 if (wantarray) { return (); } else { return undef; }
1019 }
1020 }
1021
1022 if (! exists($self->{attributes}->{$attribute})) {
1023
1024 my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
1025 my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
1026 my ($package, $filename, $line) = caller;
1027
1028 $log->error(ref($self)."): Вызов метода, для которого не существует обрабатываемого свойства: ->$attribute() called from $package/$filename/$line ".($mason_file ? "called from $mason_file" : '')."\n".Data::Dumper::Dumper($self));
1029 if (wantarray) { return (); } else { return undef; }
1030 #special work with ARRAY types
1031 } elsif ($self->{attributes}->{$attribute} eq 'ARRAY') {
1032 my $funct = "
1033 use Contenido::Globals;
1034 my \$self = shift;
1035 unless (ref(\$self->{$attribute}) eq 'ARRAY') {
1036 my (\$package, \$filename, \$line) = caller;
1037 \$log->error(\"Wrong structure in field $attribute called from \$package/\$filename/\$line \\n\".Data::Dumper::Dumper(\$self)) if (\$self->{$attribute});;
1038 \$self->{$attribute} = [];
1039 }
1040 \$self->{$attribute} = [\@_] if (\@_);
1041 return \@{\$self->{$attribute}};";
1042
1043 if (create_method($class, $attribute, $funct)) {
1044 return $self->$attribute(@_);
1045 } else {
1046 $log->error("Cannot create method $attribute for class $self->{class}");
1047 #fallback to old autoload method if create method fail
1048 unless (ref($self->{$attribute}) eq 'ARRAY') {
1049 my ($package, $filename, $line) = caller;
1050 $log->error("Wrong structure in field $attribute called from $package/$filename/$line \n".Data::Dumper::Dumper($self));
1051 $self->{$attribute} = [];
1052 }
1053 $self->{$attribute} = [@_] if (@_);
1054 return @{$self->{$attribute}};
1055 }
1056 #todo: добавить работу с images Нормальную когда она будет готова
1057 } else {
1058 #todo: валидация формата полей
1059 my $funct = "
1060 my \$self = shift;
1061 \$self->{$attribute} = shift if (\@_);
1062 return \$self->{$attribute};";
1063
1064 if (create_method($class, $attribute, $funct)) {
1065 return $self->$attribute(@_);
1066 } else {
1067 $log->error("Cannot create method $attribute for class $self->{class}");
1068 #fallback to old autoload method if create method fail
1069 $self->{$attribute} = shift if (@_);
1070 return $self->{$attribute};
1071 }
1072 }
1073 }
1074
1075 sub eval_dump {
1076 no strict 'vars';
1077 583 ahitrov if ( ref ${$_[0]} ) {
1078 return ${$_[0]};
1079 } elsif ( ${$_[0]} ) {
1080 return eval ${$_[0]};
1081 } else {
1082 return {};
1083 }
1084 8 ahitrov@rambler.ru }
1085
1086 217 ahitrov sub eval_json {
1087 return undef unless ${$_[0]};
1088 232 ahitrov my $str = ${$_[0]};
1089 613 ahitrov if ( $str =~ /^\$VAR/ ) {
1090 return Data::Recursive::Encode->decode_utf8(Contenido::Object::eval_dump( \$str ));
1091 }
1092 232 ahitrov my $chr = substr($str, 0, 1); return $str unless $chr eq '{' || $chr eq '[';
1093 my $value = $json_u->decode( $str );
1094 217 ahitrov return $value;
1095 }
1096
1097 8 ahitrov@rambler.ru sub create_method {
1098 my ($class, $sub_name, $code) = @_;
1099
1100 unless ($class and $sub_name and $code) {
1101 $log->error("Wrong call create_method $class/$sub_name/$code");
1102 return 0;
1103 }
1104
1105 my $string = "package $class;\n\nsub $sub_name {\n$code\n}\n\n1;";
1106 eval $string;
1107
1108 if ($@) {
1109 $log->error("Cannot create method $sub_name for class $class because $@ (method code:\n$string\n)");
1110 return 0;
1111 } else {
1112 $log->info("Method '$sub_name' for class '$class' (method code:\n$string\n) created ok") if ($DEBUG_CORE);
1113 return 1;
1114 }
1115 }
1116
1117 ######################################## ONLY FOR INTERNAL USE!!!! #################################################
1118 #todo добавить проверку что если классов список то проверить что у них 1 table а не 5 разных
1119 sub _get_table {
1120 my ($self, %opts) = @_;
1121
1122 my $class_table;
1123
1124 my $table=$opts{table};
1125 my $class=$opts{class} || ref $self || $self;
1126
1127 #пришла таблица в %opts
1128 if ($table and $table->can('new')) {
1129 $class_table=$table;
1130 #иначе пробуем по классу
1131 } elsif ($class and !ref($class)) {
1132 unless ($class->can('class_table')) {
1133 $log->error("$class cannot class_table");
1134 return undef;
1135 }
1136 $class_table=$class->class_table();
1137 #иначе пробуем по первому классу в списке
1138 } elsif ($class and ref($class) eq 'ARRAY' and @$class) {
1139 unless ($class->[0]->can('class_table')) {
1140 $log->error("$class->[0] cannot class_table");
1141 return undef;
1142 }
1143 $class_table=$class->[0]->class_table();
1144 #иначе умолчательную
1145 } else {
1146 $class_table='SQL::DocumentTable';
1147 }
1148
1149 if ($class_table->can('new')) {
1150 return $class_table->new();
1151 } else {
1152 $log->error("$class_table cannot new!!!!");
1153 return undef;
1154 }
1155 }
1156
1157 #######################################################################################################################
1158 ########## OLD CODE FOR COMPATIBILITY #################################################################################
1159 #######################################################################################################################
1160 sub structure {
1161 my $self = shift;
1162 my $class = ref($self);
1163 {
1164 no strict 'refs';
1165 return @${$class.'::structure'};
1166 }
1167 }
1168
1169
1170 # оставлена для обратной совместимости...
1171 sub get_image {
1172 my $self = shift;
1173 217 ahitrov if ( $self->keeper->serialize_with eq 'json' ) {
1174 return $self->get_data(shift, 'encode');
1175 } else {
1176 return $self->get_data(shift);
1177 }
1178 8 ahitrov@rambler.ru }
1179
1180 sub raw_restore {
1181 my $self = shift;
1182 do { $log->error("Метод restore() можно вызывать только у объектов, но не классов"); die } unless ref $self;
1183 do { $log->warning("Вызов метода Contenido\:\:Object\:\:raw_restore() без указания идентификатора для чтения"); return undef } unless $self->id;
1184 $self->restore_extras();
1185 }
1186
1187 sub init {
1188 my $self = shift;
1189 my $class = ref($self) || $self;
1190 $self->class_init();
1191 {
1192 no strict 'refs';
1193 $self->{attributes} = ${$class.'::attributes'};
1194 }
1195 return 1;
1196 }
1197
1198 sub get_file_name {
1199 my $self = shift;
1200
1201 do { $log->error("Метод get_file_name можно вызывать только у объектов, но не классов"); die } unless ref $self;
1202
1203 my @date;
1204 my $time = time;
1205
1206 if ($self->{"dtime"} and $self->{"dtime"} =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1207 @date = ($1, $2, $3);
1208 } else {
1209 @date = (localtime $time)[5, 4, 3]; $date[0] += 1900; $date[1] += 1;
1210 }
1211
1212 my $component_class = lc((reverse split "::", ref $self)[0]);
1213 my $component_date = sprintf "%04d/%02d/%02d", @date;
1214 my $component_time_rand = sprintf "%010d_%05d", $time, int rand 99999;
1215
1216 return join "/", $component_class, $component_date, $component_time_rand;
1217 }
1218
1219 sub get {
1220 my ( $self, %opts ) = @_;
1221 my $class = ref $self || $self;
1222 my $local_keeper = (ref($self) and ref($self->keeper)) ? $self->keeper : $keeper;
1223 delete $opts{class};
1224 return $keeper->get_documents( class => $class, %opts );
1225 }
1226
1227 592 ahitrov # Template method for object url in project.
1228 # /contenido/document.html will use it in future.
1229 ###################################################
1230 sub get_url {
1231 return;
1232 }
1233
1234 8 ahitrov@rambler.ru sub contenido_is_available {
1235 return 1;
1236 }
1237
1238 sub contenido_status_style {
1239 return;
1240 }
1241
1242 sub memcached_expire {
1243 return $_[0]->keeper->state->memcached_object_expire;
1244 }
1245
1246 113 ahitrov # ----------------------------------------------------------------------------
1247 125 ahitrov # Метод _store_image() сохраняет графику, привязанную к полю image или images
1248 113 ahitrov #
1249 # Формат использования:
1250 125 ahitrov # $document->_store_image( INPUT, attr => 'fieldname' )
1251 365 ahitrov # $document->_store_image( INPUT, prop => $prophash )
1252 113 ahitrov # ----------------------------------------------------------------------------
1253 sub _store_image {
1254 my $self = shift;
1255 do { $log->error("Метод delete() можно вызывать только у объектов, но не классов"); die } unless ref($self);
1256
1257 my $input = shift;
1258 my (%opts) = @_;
1259
1260 365 ahitrov return Contenido::File::store_image( $input, object => $self, %opts );
1261 113 ahitrov }
1262
1263 125 ahitrov # ----------------------------------------------------------------------------
1264 # Метод _delete_image() удаляет файлы, связанные с полем image или images.
1265 # Вычищает все мини-копии
1266 #
1267 # Формат использования:
1268 347 ahitrov # $document->_delete_image( $image_attr_structure )
1269 125 ahitrov # ----------------------------------------------------------------------------
1270 113 ahitrov sub _delete_image {
1271 my $self = shift;
1272 my $IMAGE = shift;
1273
1274 return Contenido::File::remove_image( $IMAGE );
1275 }
1276
1277 125 ahitrov # ----------------------------------------------------------------------------
1278 347 ahitrov # Метод _store_binary() сохраняет произвольный бинарный файл, привязанную к полю multimedia_multi или multimedia_new
1279 125 ahitrov #
1280 # Формат использования:
1281 # $document->_store_binary( INPUT, attr => 'fieldname' )
1282 # ----------------------------------------------------------------------------
1283 sub _store_binary {
1284 my $self = shift;
1285 do { $log->error("Метод delete() можно вызывать только у объектов, но не классов"); die } unless ref($self);
1286
1287 my $input = shift;
1288 my (%opts) = @_;
1289
1290 613 ahitrov return Contenido::File::store_binary( $input, object => $self, %opts );
1291 125 ahitrov }
1292
1293 # ----------------------------------------------------------------------------
1294 # Метод _delete_binary() удаляет файлы, связанные с полем multimedia или multimedia_new.
1295 # Не пытается искать мини-копии
1296 #
1297 # Формат использования:
1298 # $document->_delete_binary( $binary_attr_structure )
1299 # ----------------------------------------------------------------------------
1300 sub _delete_binary {
1301 my $self = shift;
1302 my $BINARY = shift;
1303
1304 return Contenido::File::remove_binary( $BINARY );
1305 }
1306
1307 8 ahitrov@rambler.ru 1;
1308