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