<%once> my %translit = ( 'а' => 'a', 'б' => 'b', 'в' => 'v', 'г' => 'g', 'д' => 'd', 'е' => 'e', 'ё' => 'e', 'ж' => 'zh', 'з' => 'z', 'и' => 'i', 'й' => 'y', 'к' => 'k', 'л' => 'l', 'м' => 'm', 'н' => 'n', 'о' => 'o', 'п' => 'p', 'р' => 'r', 'с' => 's', 'т' => 't', 'у' => 'u', 'ф' => 'f', 'х' => 'h', 'ц' => 'ts', 'ч' => '4', 'ш' => 'sh', 'щ' => 'sch', 'ъ' => 'y', 'ы' => 'i', 'ь' => 'y', 'э' => 'e', 'ю' => 'u', 'я' => 'a', 'А' => 'A', 'Б' => 'B', 'В' => 'V', 'Г' => 'G', 'Д' => 'D', 'Е' => 'E', 'Ё' => 'E', 'Ж' => 'ZH', 'З' => 'Z', 'И' => 'I', 'Й' => 'Y', 'К' => 'K', 'Л' => 'L', 'М' => 'M', 'Н' => 'N', 'О' => 'O', 'П' => 'P', 'Р' => 'R', 'С' => 'S', 'Т' => 'T', 'У' => 'U', 'Ф' => 'F', 'Х' => 'H', 'Ц' => 'TS', 'Ч' => '4', 'Ш' => 'SH', 'Щ' => 'SCH', 'Ъ' => 'Y', 'Ы' => 'I', 'Ь' => 'Y', 'Э' => 'E', 'Ю' => 'U', 'Я' => 'YA', ); <%args> $SETS => undef $field => undef $default=> undef $object => undef $prop => undef <%init> return undef unless defined $SETS and defined $field; #use vars qw($keeper); # -------------------------------------------------------------------------------------- # Добавление одной картинки my $BINARY = $default; if ($SETS->{$field} || $SETS->{"$field.ext_url"}) { my $upload; if ( $SETS->{$field} ) { $upload = $r->upload($field); } elsif ( $SETS->{"$field.ext_url"} && $SETS->{"$field.ext_url"} =~ /^(http|https|ftp):\/\/.*/ ) { $upload = $SETS->{"$field.ext_url"}; } if ($upload) { my $BIN = $object->_store_binary( $upload, attr => $prop->{attr} ); if ( ref $BIN eq 'HASH' && exists $BIN->{filename} ) { $object->_delete_binary( $default ); %$BINARY = %$BIN; } } else { warn 'ERROR in incoming POST form: "'.$field.' is not file upload (value: "'.$SETS->{$field}.'")'; } } # Дополнительные поля - берем все, что найдем... my $pattern = "^".$field.q|\.(.*)$|; foreach my $localfield (keys(%{ $SETS })) { if ($localfield =~ /$pattern/) { my $imagefield = $1; $BINARY->{$imagefield} = $m->comp("/contenido/components/filter.msn", str => $SETS->{$localfield}); } } return $BINARY; <%def .translit> <%args> $str => undef <%init> my @str = split (//, $str); my $res = ''; while ( scalar @str ) { my $alpha = shift @str; if ( exists $translit{$alpha} ) { $res .= $translit{$alpha}; } else { $res .= $alpha; } } return $res;