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