Revision 823

Date:
2021/06/25 22:28:36
Author:
ahitrov
Revision Log:
Recursive::Encoder -> inner perl-based encoder
Files:

Legend:

 
Added
 
Removed
 
Modified

  • utf8/core/lib/Contenido/Keeper.pm

     
    17 17
    18 18 use Contenido::Globals;
    19 19 use Contenido::Msg;
    20 use Utils;
    20 21
    21 22 # TODO
    22 23 # побить на 2-4 модуля вменяемого размера....!
    … …  
    210 211 # warn Data::Dumper::Dumper($binds);
    211 212 unless ($sth->execute(@$binds)) {
    212 213 $self->error;
    213 $log->error("DBI execute error on $$query\n".Data::Dumper::Dumper($DBD::Pg::VERSION >= '3' ? Data::Recursive::Encode->encode_utf8($binds) : $binds)."\ncalled with opts:\n".Data::Dumper::Dumper(\%opts));
    214 $log->error("DBI execute error on $$query\n".Data::Dumper::Dumper($DBD::Pg::VERSION >= '3' ? Utils::encode_struct($binds) : $binds)."\ncalled with opts:\n".Data::Dumper::Dumper(\%opts));
    214 215 return;
    215 216 }
    216 217 my $finish1 = Time::HiRes::time() if ($DEBUG);
    … …  
    236 237 $Contenido::Globals::CORE_TIME += $finish2-$finish1;
    237 238 $Contenido::Globals::DB_COUNT++;
    238 239
    239 $log->info("get_items($proto) ".($mason_file ? "called from $mason_file" : '')." SQL: '$$query' with binds: '".join("', '", map { ref $_ ? Data::Dumper::Dumper($DBD::Pg::VERSION >= '3' ? Data::Recursive::Encode->encode_utf8($_) : $_) : $DBD::Pg::VERSION >= '3' ? Encode::encode('utf-8', $_) : $_ } @$binds)."' fetched: $total records (total work time: $total_time ms, database time $db_time ms, core time $core_time ms)");
    240 $log->info("get_items($proto) ".($mason_file ? "called from $mason_file" : '')." SQL: '$$query' with binds: '".join("', '", map { ref $_ ? Data::Dumper::Dumper($DBD::Pg::VERSION >= '3' ? Utils::encode_struct($_) : $_) : $DBD::Pg::VERSION >= '3' ? Encode::encode('utf-8', $_) : $_ } @$binds)."' fetched: $total records (total work time: $total_time ms, database time $db_time ms, core time $core_time ms)");
    240 241 }
    241 242
    242 243 #выдает предупреждение если полученно более 500 обьектов но не выставлен no_limit
    243 244 if ($total>999 and !($opts{no_limit} or $opts{limit})) {
    244 245 my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
    245 246 my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
    246 $log->error("get_items($proto) ".($mason_file ? "called from $mason_file" : '')." SQL: '$$query' with binds: '".join("', '", map { ref $_ ? Data::Dumper::Dumper($DBD::Pg::VERSION >= '3' ? Data::Recursive::Encode->encode_utf8($_) : $_) : $DBD::Pg::VERSION >= '3' ? Encode::encode('utf-8', $_) : $_ } @$binds)."' fetched 1000 records... гарантированно часть записей не получена из базы... или добавьте no_limit=>1 или разберитесь почему так много данных получаете");
    247 $log->error("get_items($proto) ".($mason_file ? "called from $mason_file" : '')." SQL: '$$query' with binds: '".join("', '", map { ref $_ ? Data::Dumper::Dumper($DBD::Pg::VERSION >= '3' ? Utils::encode_struct($_) : $_) : $DBD::Pg::VERSION >= '3' ? Encode::encode('utf-8', $_) : $_ } @$binds)."' fetched 1000 records... гарантированно часть записей не получена из базы... или добавьте no_limit=>1 или разберитесь почему так много данных получаете");
    247 248 } elsif ($total>500 and !($opts{no_limit} or $opts{limit})) {
    248 249 my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
    249 250 my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;

  • utf8/core/lib/Contenido/Object.pm

     
    225 225 $virtual_fields{$attr} = 1;
    226 226 } else {
    227 227 #инициализируем из dump все кроме виртуальных свойств
    228 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 push @funct_exra_fields, "$attr=>(\$keeper->serialize_with eq 'json' ? (ref \$dump->{$attr} ? Utils::encode_struct(\$dump->{$attr}) : Encode::encode('utf-8', \$dump->{$attr}, Encode::FB_HTMLCREF) ) : $func_start_encode\$dump->{$attr}$func_end_encode)";
    229 229 }
    230 230 }
    231 231 }
    … …  
    395 395 if ( ref $self->$attr ) {
    396 396 return $self->$attr;
    397 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});
    398 my $data = $self->keeper->serialize_with eq 'json' ? ( $encode ? Utils::encode_struct(eval_json(\$self->{$attr})) : eval_json(\$self->{$attr}) ) : eval_dump(\$self->{$attr});
    399 399 return ($data || {});
    400 400 }
    401 401 }
    … …  
    476 476 } elsif ( version->parse($DBD::Pg::VERSION) > version->parse('3') && $] < '5.026' ) {
    477 477 foreach my $i (0..$#{$binds}) {
    478 478 if ( ref $binds->[$i] ) {
    479 $binds->[$i] = Data::Recursive::Encode->decode_utf8($binds->[$i]);
    479 $binds->[$i] = Utils::decode_struct($binds->[$i]);
    480 480 } else {
    481 481 $binds->[$i] = Encode::decode('utf-8', $binds->[$i], Encode::FB_HTMLCREF);
    482 482 }
    … …  
    601 601 }
    602 602 # warn Data::Dumper::Dumper(\@values) if $DEBUG;
    603 603 unless ($sth->execute(@values, $self->{id})) {
    604 $log->error("DBI execute error on $sql\n".Data::Dumper::Dumper( $DBD::Pg::VERSION >= '3' && $] < '5.026' ? Data::Recursive::Encode->encode_utf8( \@values ) : \@values ));
    604 $log->error("DBI execute error on $sql\n".Data::Dumper::Dumper( $DBD::Pg::VERSION >= '3' && $] < '5.026' ? Utils::encode_struct( \@values ) : \@values ));
    605 605 $sth->finish();
    606 606 return $self->t_abort();
    607 607 }
    … …  
    633 633 $sth->bind_param($_, undef, {pg_type => DBD::Pg::PG_BYTEA});
    634 634 }
    635 635 unless ($sth->execute(@values)) {
    636 $log->error("DBI execute error on $sql\n".Data::Dumper::Dumper( $DBD::Pg::VERSION >= '3' && $] < '5.026' ? Data::Recursive::Encode->encode_utf8( \@values ) : \@values ));
    636 $log->error("DBI execute error on $sql\n".Data::Dumper::Dumper( $DBD::Pg::VERSION >= '3' && $] < '5.026' ? Utils::encode_struct( \@values ) : \@values ));
    637 637 $sth->finish();
    638 638 return $self->t_abort();
    639 639 }
    … …  
    1091 1091 return undef unless ${$_[0]};
    1092 1092 my $str = ${$_[0]};
    1093 1093 if ( $str =~ /^\$VAR/ ) {
    1094 return Data::Recursive::Encode->decode_utf8(Contenido::Object::eval_dump( \$str ));
    1094 return Utils::decode_struct(Contenido::Object::eval_dump( \$str ));
    1095 1095 }
    1096 1096 my $chr = substr($str, 0, 1); return $str unless $chr eq '{' || $chr eq '[';
    1097 1097 my $value = $json_u->decode( $str );

  • utf8/core/lib/Utils.pm

     
    8 8 @ISA = qw(Exporter);
    9 9 @EXPORT = qw( &eval_config_file
    10 10 &dump_config_file
    11 &decode_struct
    12 &encode_struct
    11 13 &_mkdir
    12 14 &looks_like_id
    13 15 &time_unix_to_timestamp
    … …  
    204 206 my ($from, $to, $str) = @_;
    205 207 return Convert::Cyrillic::cstocs($from, $to, $str);
    206 208 }
    207
    208 209
    210 sub encode_struct {
    211 return recode_struct_recursive($_[0], 'encode');
    212 }
    213
    214 sub decode_struct {
    215 return recode_struct_recursive($_[0], 'decode');
    216 }
    217
    218 sub recode_struct_recursive {
    219 my ($struct, $action) = @_;
    220 return unless ref $struct;
    221
    222 my @stack;
    223 if ( ref $struct eq 'HASH' ) {
    224 foreach my $key ( keys %$struct ) {
    225 push @stack, { root => $struct, type => 'hash', key => $key };
    226 }
    227 } elsif ( ref $struct eq 'ARRAY' ) {
    228 for( my $i == 0; $i < scalar @$struct; $i++ ) {
    229 push @stack, { root => $struct, type => 'array', index => $i };
    230 }
    231 } else {
    232 return;
    233 }
    234 while ( @stack ) {
    235 my $data = pop @stack;
    236 if ( $data->{type} eq 'hash' ) {
    237 if ( ref $data->{root}{$data->{key}} eq 'HASH' ) {
    238 foreach my $key ( keys %{$data->{root}{$data->{key}}} ) {
    239 push @stack, { root => $data->{root}{$data->{key}}, type => 'hash', key => $key };
    240 }
    241 } elsif ( ref $data->{root}{$data->{key}} eq 'ARRAY' ) {
    242 for( my $i == 0; $i < scalar @{$data->{root}{$data->{key}}}; $i++ ) {
    243 push @stack, { root => $data->{root}{$data->{key}}, type => 'array', index => $i };
    244 }
    245 } else {
    246 if ( $action eq 'encode' ) {
    247 $data->{root}{$data->{key}} = Encode::encode('utf-8', $data->{root}{$data->{key}}, Encode::FB_HTMLCREF);
    248 } else {
    249 $data->{root}{$data->{key}} = Encode::decode('utf-8', $data->{root}{$data->{key}}, Encode::FB_HTMLCREF);
    250 }
    251 }
    252 } else {
    253 if ( ref $data->{root}->[$data->{index}] eq 'HASH' ) {
    254 foreach my $key ( keys %{$data->{root}->[$data->{index}]} ) {
    255 push @stack, { root => $data->{root}->[$data->{index}], type => 'hash', key => $key };
    256 }
    257 } elsif ( ref $data->{root}->[$data->{index}] eq 'ARRAY' ) {
    258 for( my $i == 0; $i < scalar @{$data->{root}->[$data->{index}]}; $i++ ) {
    259 push @stack, { root => $data->{root}->[$data->{index}], type => 'array', index => $i };
    260 }
    261 } else {
    262 if ( $action eq 'encode' ) {
    263 $data->{root}->[$data->{key}] = Encode::encode('utf-8', $data->{root}->[$data->{key}], Encode::FB_HTMLCREF);
    264 } else {
    265 $data->{root}->[$data->{key}] = Encode::decode('utf-8', $data->{root}->[$data->{key}], Encode::FB_HTMLCREF);
    266 }
    267 }
    268 }
    269 }
    270 return $struct;
    271 }
    272
    209 273 # загрузка модулей
    210 274 sub load_modules {
    211 275 my $list = shift;