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 785 ahitrov if ( exists $params->{insert_ignore} && $params->{insert_ignore} ) {
625 ### Can be of use only with PostgreSQL 9.5 or higher!!!
626 $sql .= ' ON CONFLICT ('.$params->{insert_ignore}.') DO NOTHING';
627 }
628 779 ahitrov warn "$sql\n" if $DEBUG;
629 8 ahitrov@rambler.ru
630 my $sth=$self->keeper->TSQL->prepare_cached($sql, {}, 1) || return $self->t_abort();
631 #settin special escape for bytea column type!!!
632 foreach (@binary_fields) {
633 $sth->bind_param($_, undef, {pg_type => DBD::Pg::PG_BYTEA});
634 }
635 unless ($sth->execute(@values)) {
636 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 ));
637 8 ahitrov@rambler.ru $sth->finish();
638 return $self->t_abort();
639 }
640 $sth->finish();
641
642 778 ahitrov unless ( $self->id ) {
643 my $id = $self->keeper->TSQL->selectrow_array("SELECT currval('".$self->class_table->db_id_sequence()."')");
644 $self->id($id);
645 return $self->t_abort("Документу присвоен неверный идентификатор") if (! defined($self->{id}) || ($self->{id} <= 0));
646 }
647 8 ahitrov@rambler.ru
648 390 ahitrov if (($self->keeper->store_method() ne 'toast') and $self->class_table->have_extra and !$self->{__light}) {
649 8 ahitrov@rambler.ru $self->store_extras(mode => $mode) || return $self->t_abort();
650 }
651
652 }
653
654 $self->post_store(mode => $mode);
655
656 $self->keeper->t_finish();
657
658 $self->post_finish_store();
659
660 $self->drop_cache($mode) if ($self->keeper->state()->memcached_enable());
661
662 return 1;
663 }
664
665 # ----------------------------------------------------------------------------
666 # Метод delete() для удаления объекта из базы данных.
667 #
668 # Формат использования:
669 # $document->delete()
670 # ----------------------------------------------------------------------------
671 sub delete {
672 my $self = shift;
673 my (%opts) = @_;
674 do { $log->error("Метод delete() можно вызывать только у объектов, но не классов"); die } unless ref($self);
675
676 return undef if ($self->keeper->state->readonly());
677
678 unless ($self->pre_delete()) {
679 $log->error("pre_delete call failed!");
680 return undef;
681 }
682
683 my $keeper = $self->keeper;
684 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($keeper);
685
686 390 ahitrov my $delete_attachments = exists $opts{attachments} ? $opts{attachments} : 1;
687 if ( $delete_attachments ) {
688 8 ahitrov@rambler.ru my @props = $self->structure();
689 if ( @props ) {
690 347 ahitrov @props = grep { $_->{type} =~ /^(image|images|multimedia_new|multimedia_multi)$/ } @props;
691 8 ahitrov@rambler.ru foreach my $prop ( @props ) {
692 my $att = $self->get_image($prop->{attr});
693 if ( $prop->{type} eq 'image' ) {
694 if ( ref $att && exists $att->{filename} && $att->{filename} ) {
695 Contenido::File::remove( $att->{filename} );
696 }
697 55 ahitrov@rambler.ru if ( exists $att->{mini} && ref $att->{mini} eq 'HASH' ) {
698 Contenido::File::remove( $att->{mini}{filename} ) if exists $att->{mini}{filename};
699 foreach my $val ( values %{ $att->{mini} } ) {
700 if ( ref $val && exists $val->{filename} && $val->{filename} && ($val->{filename} ne $att->{mini}{filename}) ) {
701 Contenido::File::remove( $val->{filename} );
702 8 ahitrov@rambler.ru }
703 }
704 }
705
706 } elsif ( $prop->{type} eq 'images' ) {
707 for ( 1..100 ) {
708 next unless exists $att->{"image_$_"};
709 my $img = $att->{"image_$_"};
710 if ( ref $img && exists $img->{filename} && $img->{filename} ) {
711 Contenido::File::remove( $img->{filename} );
712 }
713 55 ahitrov@rambler.ru if ( exists $img->{mini} && ref $img->{mini} eq 'HASH' ) {
714 Contenido::File::remove( $img->{mini}{filename} ) if exists $img->{mini}{filename};
715 foreach my $val ( values %{ $img->{mini} } ) {
716 if ( ref $val && exists $val->{filename} && $val->{filename} && ($val->{filename} ne $img->{mini}{filename}) ) {
717 Contenido::File::remove( $val->{filename} );
718 8 ahitrov@rambler.ru }
719 }
720 }
721 }
722 } elsif ( $prop->{type} eq 'multimedia_new' ) {
723 if ( ref $att && exists $att->{filename} && $att->{filename} ) {
724 Contenido::File::remove( $att->{filename} );
725 }
726 347 ahitrov } elsif ( $prop->{type} eq 'multimedia_multi' ) {
727 for ( 1..100 ) {
728 next unless exists $att->{"file_$_"};
729 my $file = $att->{"file_$_"};
730 if ( ref $file && exists $file->{filename} && $file->{filename} ) {
731 Contenido::File::remove( $file->{filename} );
732 }
733 }
734 8 ahitrov@rambler.ru }
735 }
736 }
737 }
738 45 ahitrov@rambler.ru do { $log->warning("Вызов метода delete() без указания идентификатора для удаления"); return undef }
739 55 ahitrov@rambler.ru unless ($self->{id});
740 8 ahitrov@rambler.ru $keeper->t_connect() || do { $keeper->error(); return undef; };
741 $keeper->TSQL->do("DELETE FROM ".$self->class_table->db_table." WHERE id = ?", {}, $self->id) || return $self->t_abort();
742
743 # Удаление связей этого документа с другими документами...
744 my %document_links;
745 if ( $keeper->state->{available_links} && ref $keeper->state->{available_links} eq 'ARRAY' ) {
746 foreach my $classlink ( @{ $keeper->state->{available_links} } ) {
747 my $sources = $classlink->available_sources;
748 if ( ref $sources eq 'ARRAY' && @$sources ) {
749 $document_links{$classlink->class_table->db_table}{source} = 1 if grep { $self->class eq $_ } @$sources;
750 }
751 my $dests = $classlink->available_destinations;
752 if ( ref $dests eq 'ARRAY' && @$dests ) {
753 45 ahitrov@rambler.ru $document_links{$classlink->class_table->db_table}{dest} = 1 if grep { $self->class eq $_ } @$dests;
754 8 ahitrov@rambler.ru }
755 }
756 foreach my $tablename ( keys %document_links ) {
757 my (@wheres, @values);
758 if ( exists $document_links{$tablename}{source} ) {
759 push @wheres, "(source_id = ? AND source_class = ?)";
760 push @values, ( $self->id, $self->class );
761 }
762 if ( exists $document_links{$tablename}{dest} ) {
763 push @wheres, "(dest_id = ? AND dest_class = ?)";
764 push @values, ( $self->id, $self->class );
765 }
766 my $request = "DELETE FROM $tablename WHERE ".join (' OR ', @wheres);
767 warn "DELETE LINKS. Request: [$request]\n" if $DEBUG;
768 warn "Values: [".join(', ', @values)."]\n" if $DEBUG;
769 $keeper->TSQL->do($request, {}, @values) || return $self->t_abort();
770 }
771 } else {
772 $keeper->TSQL->do("DELETE FROM links WHERE source_id = ? AND source_class = ? ", {}, $self->id, $self->class) || return $self->t_abort();
773 $keeper->TSQL->do("DELETE FROM links WHERE dest_id = ? AND dest_class = ? ", {}, $self->id, $self->class) || return $self->t_abort();
774 }
775 $keeper->t_finish();
776
777 $self->post_delete();
778
779 $self->drop_cache('delete') if ($keeper->state()->memcached_enable());
780
781 return 1;
782 }
783
784 # ----------------------------------------------------------------------------
785 # Метод links() возвращает массив объектов типа Contenido::Link
786 #
787 # Формат использования:
788 # $document->links([класс])
789 # ----------------------------------------------------------------------------
790 sub links {
791 my ($self, $lclass, $direction, %opts) = @_;
792 do { $log->error("Метод ->links() можно вызывать только у объектов, но не классов"); die } unless ref($self);
793
794 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($self->keeper);
795
796 do { $log->warning("Вызов метода ->links() без указания идентификатора сообщения-источника"); return () } unless ($self->id() > 0);
797
798 my $check = defined $direction ? 'dest_id' : 'source_id';
799
800 $opts{$check} = $self->id();
801
802 if (defined($lclass) && (length($lclass) > 0)) {
803 55 ahitrov@rambler.ru $opts{class} = $lclass;
804 8 ahitrov@rambler.ru }
805
806 my @links = $self->keeper->get_links(%opts);
807
808 $self->{links} = \@links;
809 return @links;
810 }
811
812
813 sub linked_to {
814 my ($self, $lclass) = @_;
815 $self->links($lclass, 1);
816 }
817
818
819 # ----------------------------------------------------------------------------
820 # Установка связи. Должен быть обязательно задан класс...
821 # В качестве source_id выступает идентификатор объекта, в качестве $dest_id -
822 # заданный.
823 #
824 # Формат использования:
825 # $document->set_link($lclass, $dest_id)
826 #
827 # Проверки не производится - у сообщения может быть несколько одинаковых
828 # связей.
829 # ----------------------------------------------------------------------------
830 sub set_link {
831 my ($self, $lclass, $dest_id, $dest_class, @opts) = @_;
832 do { $log->error("Метод ->set_link() вызван с неправильным кол-вом агрументов"); die } if @opts % 2;
833 do { $log->error("Метод ->set_link() можно вызывать только у объектов, но не классов"); die } unless ref($self);
834 my %opts = @opts;
835
836 return undef if ($self->keeper->state->readonly());
837
838 do { $log->warning("Вызов метода ->set_link() без указания идентификатора сообщения-источника"); return undef } unless ($self->id() > 0);
839 do { $log->warning("Вызов метода ->set_link() без указания идентификатора сообщения-цели"); return undef } unless ($dest_id >= 0);
840 115 ahitrov do { $log->warning("Вызов метода ->set_link() без указания класса связи"); } unless defined($lclass) && length($lclass);
841 8 ahitrov@rambler.ru
842 # Создаем объект связи...
843 my $link = $lclass->new($self->keeper);
844
845 $link->dest_id($dest_id);
846 $link->dest_class($dest_class);
847
848 $link->status(1);
849
850 $link->source_id($self->id());
851 $link->source_class($self->class());
852
853 while (my ($k,$v) = each %opts) {
854 55 ahitrov@rambler.ru $link->{$k} = $v;
855 8 ahitrov@rambler.ru }
856
857 if ($link->store())
858 {
859 55 ahitrov@rambler.ru return $link->id;
860 8 ahitrov@rambler.ru } else {
861 55 ahitrov@rambler.ru return undef;
862 8 ahitrov@rambler.ru }
863 }
864
865 # -------------------------------------------------------------------
866 # Превращает объект в проблессенный хэш.
867 #
868 sub prepare_for_cache {
869 my $self = shift;
870
871 do { $log->error("Метод ->prepare_for_cache() можно вызывать только у объектов, но не классов"); die } unless ref($self);
872
873 my $hash = {};
874
875 foreach ( $self->structure() ) {
876 55 ahitrov@rambler.ru $hash->{$_->{attr}} = $self->{$_->{attr}} if defined $self->{$_->{attr}};
877 8 ahitrov@rambler.ru }
878 bless $hash, $self->class();
879 return $hash;
880 }
881
882 # -------------------------------------------------------------------
883 # Восстанавливает полноценный объект по проблессенному хэшу.
884 # Хэш при этом превращается в полноценный объект.
885 # -------------------------------------------------------------------
886 sub recover_from_cache {
887 my $self = shift;
888 my $keeper = shift;
889
890 do { $log->error("Метод ->recover_from_cache() можно вызывать только у объектов, но не классов"); die } unless ref($self);
891 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($keeper);
892
893 #не нужен тут bless очередной... 100% если уж попали в обьектный метод то он явно имеет класс нужный
894 $self->init();
895 $self->keeper($keeper);
896
897 return 1;
898 }
899
900 # -------------------------------------------------------------------
901 # Возвращает хэш:
902 # {действие1 => [кэш1, кэш2, ...], действие2 => [кэш1, кэш2, ...], ...}
903 # Т.е. для каждого действия задается список имен ключей в кэше,
904 # которые надо удалить.
905 # Дефолтные значени действий: insert, update, delete
906 # Для более сложной логики работы этот метод должен быть переопределен
907 # в классе самого объекта
908 #
909 sub dependencies {
910 my ($self, $mode) = @_;
911
912 my @keys = ($self->get_object_key,);
913 my $object_unique_key = $self->get_object_unique_key;
914 push @keys, $object_unique_key if defined $object_unique_key;
915
916 return
917 ($mode eq 'delete') || ($mode eq 'insert') || ($mode eq 'update')
918 ? \@keys
919 : [];
920 }
921
922 # -------------------------------------------------------------------
923 # Удаляет из кэша ключи, заданные при помощи dependencies().
924 # Пример вызова:
925 # $group->drop_cache('update');
926 #
927 sub drop_cache {
928 my $self = shift;
929 my $mode = shift;
930
931 do { $log->error("Метод ->drop_cache() можно вызывать только у объектов, но не классов"); die } unless ref($self);
932
933 my $keeper = $self->keeper;
934 do { $log->error("В объекте документа не определена ссылка на базу данных"); die } unless ref($keeper);
935
936 my $dependencies = $self->dependencies($mode, @_);
937
938 my @not_deleted = ();
939 if ( defined($dependencies) && (ref($dependencies) eq 'ARRAY') ) {
940 for (@$dependencies) {
941 my $res = $self->keeper->MEMD ? $self->keeper->MEMD->delete($_) : undef;
942 push @not_deleted, $_ unless $res;
943 $keeper->MEMD->delete($_) if ($keeper->MEMD);
944 }
945 }
946 return @not_deleted;
947 }
948
949
950 sub keeper {
951 my $self = shift;
952 my $project_keeper = shift;
953
954 do { $log->error("Метод keeper() можно вызывать только у объектов, но не классов"); die } unless ref($self);
955
956 if ($project_keeper && ref $project_keeper) {
957 $self->{keeper} = $project_keeper;
958 return $project_keeper;
959 }
960 return $self->{keeper} && ref $self->{keeper} ? $self->{keeper} : $keeper;
961 }
962
963 #делаем затычку для init_from_db чтобы проинициализировать класс если надо
964 sub init_from_db {
965 my $self = shift;
966
967 my $class = ref($self) || $self;
968
969 #защита от бесконечной рекурсии если class_init не срабатывает
970 if (defined($_[-1]) and ($_[-1] eq 'RECURSIVE CALL FLAG!')) {
971 do { $log->error("$class cannot be initialized (->class_init dont work) (recursive call) !!!"); die };
972 }
973
974 #если клас каким то странным образом все еще не проинициализирован то попробовать проинициализировать
975 #только инициализация метода init_from_db допускает не ref на входе
976 if ($class and $class->isa('Contenido::Object')) {
977 no strict 'refs';
978 if (${$class.'::class_init_done'}) {
979 do { $log->error("$class already initialized but DONT HAVE init_from_db method!!!"); die };
980 } else {
981 if ($self->class_init()) {
982 return $self->init_from_db(@_, 'RECURSIVE CALL FLAG!');
983 } else {
984 do { $log->error("$class cannot be initialized (->class_init dont work) !!!"); die };
985 }
986 }
987 } else {
988 do { $log->error("$class cannot be initialized (not Contenido::Object child class) !!!"); die };
989 }
990 }
991
992 # ----------------------------------------------------------------------------
993 # Это умный AUTOLOAD. Ловит методов для установки/чтения полей...
994 # Версия 1.0
995 # теперь он герерирует необходимый метод доступу если надо
996 # ----------------------------------------------------------------------------
997 sub AUTOLOAD {
998 my $self = shift;
999 my $attribute = $AUTOLOAD;
1000
1001 $log->info("$self calling AUTOLOAD method: $attribute") if ($DEBUG_CORE);
1002
1003 $attribute=~s/^.*:://;
1004
1005 my $class = ref($self);
1006 unless ($class and $class->isa('Contenido::Object')) {
1007
1008 my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
1009 my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
1010 my ($package, $filename, $line) = caller;
1011
1012 $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));
1013 if (wantarray) { return (); } else { return undef; }
1014 }
1015
1016 #вообщето сюда было бы не плохо засунуть инициализацию класса если уж мы каким то хреном сюда попали для неинициализированного класса
1017 {
1018 no strict 'refs';
1019 unless (${$class.'::class_init_done'}) {
1020 my ($package, $filename, $line) = caller;
1021 $log->error("AUTOLOAD called method '$attribute' for not initialised class ($class) from '$package/$filename/$line'");
1022 if (wantarray) { return (); } else { return undef; }
1023 }
1024 }
1025
1026 if (! exists($self->{attributes}->{$attribute})) {
1027
1028 my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
1029 my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
1030 my ($package, $filename, $line) = caller;
1031
1032 $log->error(ref($self)."): Вызов метода, для которого не существует обрабатываемого свойства: ->$attribute() called from $package/$filename/$line ".($mason_file ? "called from $mason_file" : '')."\n".Data::Dumper::Dumper($self));
1033 if (wantarray) { return (); } else { return undef; }
1034 #special work with ARRAY types
1035 } elsif ($self->{attributes}->{$attribute} eq 'ARRAY') {
1036 my $funct = "
1037 use Contenido::Globals;
1038 my \$self = shift;
1039 unless (ref(\$self->{$attribute}) eq 'ARRAY') {
1040 my (\$package, \$filename, \$line) = caller;
1041 \$log->error(\"Wrong structure in field $attribute called from \$package/\$filename/\$line \\n\".Data::Dumper::Dumper(\$self)) if (\$self->{$attribute});;
1042 \$self->{$attribute} = [];
1043 }
1044 \$self->{$attribute} = [\@_] if (\@_);
1045 return \@{\$self->{$attribute}};";
1046
1047 if (create_method($class, $attribute, $funct)) {
1048 return $self->$attribute(@_);
1049 } else {
1050 $log->error("Cannot create method $attribute for class $self->{class}");
1051 #fallback to old autoload method if create method fail
1052 unless (ref($self->{$attribute}) eq 'ARRAY') {
1053 my ($package, $filename, $line) = caller;
1054 $log->error("Wrong structure in field $attribute called from $package/$filename/$line \n".Data::Dumper::Dumper($self));
1055 $self->{$attribute} = [];
1056 }
1057 $self->{$attribute} = [@_] if (@_);
1058 return @{$self->{$attribute}};
1059 }
1060 #todo: добавить работу с images Нормальную когда она будет готова
1061 } else {
1062 #todo: валидация формата полей
1063 my $funct = "
1064 my \$self = shift;
1065 \$self->{$attribute} = shift if (\@_);
1066 return \$self->{$attribute};";
1067
1068 if (create_method($class, $attribute, $funct)) {
1069 return $self->$attribute(@_);
1070 } else {
1071 $log->error("Cannot create method $attribute for class $self->{class}");
1072 #fallback to old autoload method if create method fail
1073 $self->{$attribute} = shift if (@_);
1074 return $self->{$attribute};
1075 }
1076 }
1077 }
1078
1079 sub eval_dump {
1080 no strict 'vars';
1081 583 ahitrov if ( ref ${$_[0]} ) {
1082 return ${$_[0]};
1083 } elsif ( ${$_[0]} ) {
1084 return eval ${$_[0]};
1085 } else {
1086 return {};
1087 }
1088 8 ahitrov@rambler.ru }
1089
1090 217 ahitrov sub eval_json {
1091 return undef unless ${$_[0]};
1092 232 ahitrov my $str = ${$_[0]};
1093 613 ahitrov if ( $str =~ /^\$VAR/ ) {
1094 return Data::Recursive::Encode->decode_utf8(Contenido::Object::eval_dump( \$str ));
1095 }
1096 232 ahitrov my $chr = substr($str, 0, 1); return $str unless $chr eq '{' || $chr eq '[';
1097 my $value = $json_u->decode( $str );
1098 217 ahitrov return $value;
1099 }
1100
1101 8 ahitrov@rambler.ru sub create_method {
1102 my ($class, $sub_name, $code) = @_;
1103
1104 unless ($class and $sub_name and $code) {
1105 $log->error("Wrong call create_method $class/$sub_name/$code");
1106 return 0;
1107 }
1108
1109 my $string = "package $class;\n\nsub $sub_name {\n$code\n}\n\n1;";
1110 eval $string;
1111
1112 if ($@) {
1113 $log->error("Cannot create method $sub_name for class $class because $@ (method code:\n$string\n)");
1114 return 0;
1115 } else {
1116 $log->info("Method '$sub_name' for class '$class' (method code:\n$string\n) created ok") if ($DEBUG_CORE);
1117 return 1;
1118 }
1119 }
1120
1121 ######################################## ONLY FOR INTERNAL USE!!!! #################################################
1122 #todo добавить проверку что если классов список то проверить что у них 1 table а не 5 разных
1123 sub _get_table {
1124 my ($self, %opts) = @_;
1125
1126 my $class_table;
1127
1128 my $table=$opts{table};
1129 my $class=$opts{class} || ref $self || $self;
1130
1131 #пришла таблица в %opts
1132 if ($table and $table->can('new')) {
1133 $class_table=$table;
1134 #иначе пробуем по классу
1135 } elsif ($class and !ref($class)) {
1136 unless ($class->can('class_table')) {
1137 $log->error("$class cannot class_table");
1138 return undef;
1139 }
1140 $class_table=$class->class_table();
1141 #иначе пробуем по первому классу в списке
1142 } elsif ($class and ref($class) eq 'ARRAY' and @$class) {
1143 unless ($class->[0]->can('class_table')) {
1144 $log->error("$class->[0] cannot class_table");
1145 return undef;
1146 }
1147 $class_table=$class->[0]->class_table();
1148 #иначе умолчательную
1149 } else {
1150 $class_table='SQL::DocumentTable';
1151 }
1152
1153 if ($class_table->can('new')) {
1154 return $class_table->new();
1155 } else {
1156 $log->error("$class_table cannot new!!!!");
1157 return undef;
1158 }
1159 }
1160
1161 #######################################################################################################################
1162 ########## OLD CODE FOR COMPATIBILITY #################################################################################
1163 #######################################################################################################################
1164 sub structure {
1165 my $self = shift;
1166 my $class = ref($self);
1167 {
1168 no strict 'refs';
1169 return @${$class.'::structure'};
1170 }
1171 }
1172
1173
1174 # оставлена для обратной совместимости...
1175 sub get_image {
1176 my $self = shift;
1177 217 ahitrov if ( $self->keeper->serialize_with eq 'json' ) {
1178 return $self->get_data(shift, 'encode');
1179 } else {
1180 return $self->get_data(shift);
1181 }
1182 8 ahitrov@rambler.ru }
1183
1184 sub raw_restore {
1185 my $self = shift;
1186 do { $log->error("Метод restore() можно вызывать только у объектов, но не классов"); die } unless ref $self;
1187 do { $log->warning("Вызов метода Contenido\:\:Object\:\:raw_restore() без указания идентификатора для чтения"); return undef } unless $self->id;
1188 $self->restore_extras();
1189 }
1190
1191 sub init {
1192 my $self = shift;
1193 my $class = ref($self) || $self;
1194 $self->class_init();
1195 {
1196 no strict 'refs';
1197 $self->{attributes} = ${$class.'::attributes'};
1198 }
1199 return 1;
1200 }
1201
1202 sub get_file_name {
1203 my $self = shift;
1204
1205 do { $log->error("Метод get_file_name можно вызывать только у объектов, но не классов"); die } unless ref $self;
1206
1207 my @date;
1208 my $time = time;
1209
1210 if ($self->{"dtime"} and $self->{"dtime"} =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1211 @date = ($1, $2, $3);
1212 } else {
1213 @date = (localtime $time)[5, 4, 3]; $date[0] += 1900; $date[1] += 1;
1214 }
1215
1216 my $component_class = lc((reverse split "::", ref $self)[0]);
1217 my $component_date = sprintf "%04d/%02d/%02d", @date;
1218 my $component_time_rand = sprintf "%010d_%05d", $time, int rand 99999;
1219
1220 return join "/", $component_class, $component_date, $component_time_rand;
1221 }
1222
1223 sub get {
1224 my ( $self, %opts ) = @_;
1225 my $class = ref $self || $self;
1226 my $local_keeper = (ref($self) and ref($self->keeper)) ? $self->keeper : $keeper;
1227 delete $opts{class};
1228 return $keeper->get_documents( class => $class, %opts );
1229 }
1230
1231 592 ahitrov # Template method for object url in project.
1232 # /contenido/document.html will use it in future.
1233 ###################################################
1234 sub get_url {
1235 return;
1236 }
1237
1238 8 ahitrov@rambler.ru sub contenido_is_available {
1239 return 1;
1240 }
1241
1242 sub contenido_status_style {
1243 return;
1244 }
1245
1246 sub memcached_expire {
1247 return $_[0]->keeper->state->memcached_object_expire;
1248 }
1249
1250 113 ahitrov # ----------------------------------------------------------------------------
1251 125 ahitrov # Метод _store_image() сохраняет графику, привязанную к полю image или images
1252 113 ahitrov #
1253 # Формат использования:
1254 125 ahitrov # $document->_store_image( INPUT, attr => 'fieldname' )
1255 365 ahitrov # $document->_store_image( INPUT, prop => $prophash )
1256 113 ahitrov # ----------------------------------------------------------------------------
1257 sub _store_image {
1258 my $self = shift;
1259 do { $log->error("Метод delete() можно вызывать только у объектов, но не классов"); die } unless ref($self);
1260
1261 my $input = shift;
1262 my (%opts) = @_;
1263
1264 365 ahitrov return Contenido::File::store_image( $input, object => $self, %opts );
1265 113 ahitrov }
1266
1267 125 ahitrov # ----------------------------------------------------------------------------
1268 # Метод _delete_image() удаляет файлы, связанные с полем image или images.
1269 # Вычищает все мини-копии
1270 #
1271 # Формат использования:
1272 347 ahitrov # $document->_delete_image( $image_attr_structure )
1273 125 ahitrov # ----------------------------------------------------------------------------
1274 113 ahitrov sub _delete_image {
1275 my $self = shift;
1276 my $IMAGE = shift;
1277
1278 return Contenido::File::remove_image( $IMAGE );
1279 }
1280
1281 125 ahitrov # ----------------------------------------------------------------------------
1282 347 ahitrov # Метод _store_binary() сохраняет произвольный бинарный файл, привязанную к полю multimedia_multi или multimedia_new
1283 125 ahitrov #
1284 # Формат использования:
1285 # $document->_store_binary( INPUT, attr => 'fieldname' )
1286 # ----------------------------------------------------------------------------
1287 sub _store_binary {
1288 my $self = shift;
1289 do { $log->error("Метод delete() можно вызывать только у объектов, но не классов"); die } unless ref($self);
1290
1291 my $input = shift;
1292 my (%opts) = @_;
1293
1294 613 ahitrov return Contenido::File::store_binary( $input, object => $self, %opts );
1295 125 ahitrov }
1296
1297 # ----------------------------------------------------------------------------
1298 # Метод _delete_binary() удаляет файлы, связанные с полем multimedia или multimedia_new.
1299 # Не пытается искать мини-копии
1300 #
1301 # Формат использования:
1302 # $document->_delete_binary( $binary_attr_structure )
1303 # ----------------------------------------------------------------------------
1304 sub _delete_binary {
1305 my $self = shift;
1306 my $BINARY = shift;
1307
1308 return Contenido::File::remove_binary( $BINARY );
1309 }
1310
1311 8 ahitrov@rambler.ru 1;
1312