|
|
www.lissyara.su
—> статьи
—> FreeBSD
—> Programming
—> CRUD Perl Web
Реализация CRUD + SQL::Abstract на Perl (в MVC Catalyst)
Автор: ProFTP.
email: q7u5@ukr.net
В данной статье рассматривается реализация CRUD под perl. Все кто программируют под web знают, что главная проблема веб программирования обработать HTML form тэги (<form></form>) и при этом работать с БД (как правило с различными СУБД), что в некоторых случаях бывает затруднительно. CRUD - (англ. create read update delete — «Создание чтение обновление удаление»):
Операция SQL-оператор
Создание INSERT
Чтение SELECT
Редактирование UPDATE
Удаление DELETE
| Реализовано в Django на Python, Ruby on Rails, на многих фреймворках Java и php symfony YII
Catalyst::Controller::FormBuilder от CGI::FormBuilder
Catalyst::Controller::FormFu от HTML::FormFu
Catalyst::Plugin::Form::Processor от Form::Processor
Rose::HTML::Form
Catalyst::Plugin::CRUD
CatalystX::ListFramework::Builder
CatalystX::CRUD::YUI
BasicCRUD
Более детально, например, при ошибке нужно все заполненные данные вернуть пользователю обратно, ну и указать в чем именно ошибка. Для удобного программирования в современных языках программирования есть ORM (англ. Object-relational mapping, русск. Объектно-реляционная проекция) присутствуют практически во всех веб фремворках, они необходимы для решения проблем при работе с реляционными системами управления базами данных. Использование реляционной базы данных для хранения объектно-ориентированных данных приводит к семантическому провалу, заставляя программистов писать программное обеспечение, которое должно уметь как обрабатывать данные в объектно-ориентированном виде, так и уметь сохранить эти данные в реляционной форме. Эта постоянная необходимость в преобразовании между двумя разными формами данных не только сильно снижает производительность, но и создает трудности для программистов, так как обе формы данных накладывают ограничения друг на друга.
Некоторые реализации ORM автоматически синхронизируют загруженные в память объекты с базой данных. Для того чтобы это было возможным, после создания объект-в-SQL-преобразующего SQL-запроса полученные данные копируются в поля объекта, как во всех других реализациях ORM. После этого объект должен следить за изменениями этих значений и записывать их в базу данных.
Системы управления реляционными базами данных показывают хорошую производительность на глобальных запросах, которые затрагивают большой участок базы данных, но объектно-ориентированный доступ более эффективен при работе с малыми объёмами данных, так как это позволяет сократить семантический провал между объектной и реляционной формами данных.
С точки зрения программиста система должна выглядеть как постоянное хранилище объектов. Он может просто создавать объекты и работать с ними как обычно, а они автоматически будут сохраняться в реляционной базе данных.
На практике всё не так просто и очевидно. Все системы ORM обычно проявляют себя в том или ином виде, уменьшая в некотором роде возможность игнорирования базы данных. Более того, слой транзакций может быть медленным и неэффективным (особенно в терминах сгенерированного SQL). Все это может привести к тому, что программы будут работать медленнее и использовать больше памяти, чем программы, написанные «вручную».
Но ORM избавляет программиста от написания большого количества кода, часто однообразного и подверженного ошибкам, тем самым значительно повышая скорость разработки. Кроме того, большинство современных реализаций ORM позволяют программисту при необходимости самому жёстко задать код SQL-запросов, который будет использоваться при тех или иных действиях (сохранение в базу данных, загрузка, поиск и т. д.) с постоянным объектом.
на perl: Class::DBI (CDBI), DBIx::Class(DBIC), Rose::DB::Object (RDBO) и другие
Важно сказать, про шаблоны программирования на которых основаны фремворки, большинство из них которые под web основаны на модели MVC, позволяют использовать основную бизнес логику в контролерах, модели как правило дополнительный классы (тот же ORM) и представление - это HTML или XML шаблон. Но как правило у них очень много возможностей и по этому много исходного кода, они очень ресурсоемкие, единственное целесообразно использовать их в очень больших проектах. Многие программисты не согласны с тем как построенные данные фремворки, главный недостаток, отсутствие провидения большого рефакторинга с помощью тестирования для улучшения парадигм или для ускорение работы программ (и уменьшение потребляемой памяти). Что использовать выбирайте сами.
покажу свой класс реализацию CRUD для SQL::Abstract
Примечание:
1) я продемонстрировал реализацию CRUD, для моих проектов этого было вполне достаточно, я не делал класс максимально удобно и с большими возможностями, по той причине, что каждый может написать/дописать так как захочет.
2) если что-то не понятно - спрашивайте, потому что я не знаю, то что вы не знаете, по этому комментарнии написал слабые.
3) использовать можно не только в MVC Catalyst.
use strict;
use warnings;
use parent qw( Catalyst::Model Class::Accessor);
use Class::C3::Adopt::NEXT;
use HTML::Entities::Numbered;
__PACKAGE__->mk_accessors(qw/bad_fields_type all_fields_type/);
# наследуем конструктор, если пригодиться
sub new {
my ( $self, $c ) = @_;
$self = $self->next::method(@_);
}
sub no_sql {
my $self = shift;
$self->{no_sql} = 1;
return $self;
}
sub no_bad {
my $self = shift;
$self->{no_bad} = 1;
return $self;
}
####
# Add out fields
###
sub _add_sql_fields {
my ($self) = @_;
if ( $self->{no_sql} ) {
delete $self->{no_sql};
return;
}
if ( $self->sql_fields_type eq 'array' ) {
if ( !$self->{sql_array_out} ) {
$self->{sql_array_out} = [];
}
push @{ $self->{sql_array_out} },
$self->{key};
# is $self->fails_type array
}
if ( $self->sql_fields_type eq 'hash' ) {
$self->{sql_hash_out}->{ $self->{key} } =
$self->{value};
# $self->fails_type
# HASH key = faild, value = name
}
}
sub _add_bad_fields {
my ($self) = @_;
if ( $self->{no_bad} ) {
delete $self->{no_bad};
return;
}
if ( $self->bad_fields_type eq 'array' ) {
if ( !$self->{bad_array_out} ) {
$self->{bad_array_out} = [];
}
push @{ $self->{bad_array_out} },
$self->{key};
# is $self->fails_type array
}
if ( $self->bad_fields_type eq 'hash' ) {
$self->{bad_hash_out}->{ $self->{key} } =
$self->{value};
# $self->fails_type
# HASH key = faild, value = name
}
}
sub _add_all_fields {
my ($self) = @_;
if ( $self->{no_sql} ) {
delete $self->{no_sql};
return;
}
if ( $self->all_fields_type eq 'array' ) {
if ( !@{ $self->{all_array_out} } ) {
$self->{all_array_out} = [];
}
push @{ $self->{all_array_out} },
$self->{key};
# is $self->fails_type array
}
if ( $self->all_fields_type eq 'hash' ) {
$self->{all_hash_out}->{ $self->{key} } =
$self->{value};
# $self->fails_type
# HASH key = faild, value = name
}
}
####
# Clean text, remove bad tag, etc
###
sub _del_blanks_end_began {
my $self = shift;
$self->{value} =~ s/^\s+//;
$self->{value} =~ s/\s+$//;
return $self;
}
sub _cleaning {
my $self = shift;
$self->{value} =~ s!\0!!g;
$self->{value} =~ s|&|;|g;
$self->{value} =~ s|<!--||g;
$self->{value} =~ s|-->||g;
$self->{value} =~ s|<script||ig;
$self->{value} =~ s|>||g;
$self->{value} =~ s|<||g;
$self->{value} =~ s|"||g;
$self->{value} =~ s| | |g;
$self->{value} =~ s!\|!|!g;
$self->{value} =~ s|\n||g;
$self->{value} =~ s|\$||g;
$self->{value} =~ s|\r||g;
$self->{value} =~ s|\_\_(.+?)\_\_||g;
$self->{value} =~ s|\\||g;
$self->{value} =~ s|\'||g;
$self->{value} =~ s|!||g;
return $self;
}
sub _clean_html {
my $self = shift;
$self->{value} = name2decimal( $self->{value} );
return $self;
}
####
# Valid fields
###
# return $self->{value} and off
sub out {
return shift->{value};
}
sub head_text {
my $self = shift;
$self->{key} = shift if @_;
$self->{value} = shift if @_;
$self->{value} ||= '';
$self->_del_blanks_end_began;
$self->_cleaning;
$self->_add_all_fields();
return $self;
}
sub cut_xss {
my $self = shift;
$self->{key} = shift if @_;
$self->{value} = shift if @_;
$self->{value} ||= '';
$self->_del_blanks_end_began;
$self->_clean_html;
return $self;
}
sub valid_id {
my $self = shift;
$self->{key} = shift;
$self->{value} = shift;
$self->{value} ||= '';
$self->_del_blanks_end_began();
$self->_add_all_fields();
if ( $self->{value} !~ /^\d+$/ ) {
$self->_add_bad_fields();
}
return $self
}
sub int_check {
my $self = shift;
$self->{key} = shift if @_;
$self->{value} = shift if @_;
$self->{value} ||= '';
$self->_del_blanks_end_began();
$self->{value} = $self->{value} eq 'on' ? 1 : 0;
$self->_add_all_fields();
return $self
}
sub one_die {
my $self = shift;
$self->{key} = shift if @_;
$self->{value} = shift if @_;
$self->{value} ||= '';
$self->_del_blanks_end_began();
$self->_add_all_fields();
if ( !$self->{value} == 1 ) {
$self->_add_bad_fields();
}
return $self;
}
sub zero_die {
my $self = shift;
$self->{key} = shift if @_;
$self->{value} = shift if @_;
$self->{value} ||= '';
$self->_del_blanks_end_began();
$self->_add_all_fields();
if ( !$self->{value} == 0 ) {
$self->_add_bad_fields();
}
return $self;
}
sub exist_die {
my $self = shift;
$self->{key} = shift if @_;
$self->{value} = shift if @_;
$self->{value} ||= '';
$self->_add_all_fields();
if ( !$self->{value} ) {
$self->_add_bad_fields();
}
return $self
}
sub addition {
my $self = shift;
$self->{key} = shift if @_;
$self->{value} = shift if @_;
$self->{value} ||= '';
$self->_add_all_fields();
return $self
}
sub del_doublets {
my $self = shift;
my $arr = shift if @_;
my %h;
@{$arr} = grep {! $h{"@$_"}++} @{$arr};
return $arr;
}
####
# Out fields all and bad
###
sub out_all {
my $self = shift;
if ( $self->{all_array_out} && $self->all_fields_type eq 'array' ) {
return $self->{all_array_out};
}
if ( $self->{all_hash_out} && $self->all_fields_type eq 'hash' ) {
return $self->{all_hash_out};
}
}
sub out_bad {
my $self = shift;
if ( @{ $self->{bad_array_out} } && $self->bad_fields_type eq 'array' ) {
return $self->{bad_array_out};
}
if ( $self->{bad_hash_out} && $self->bad_fields_type eq 'hash' ) {
return $self->{bad_hash_out};
}
}
sub out_sql {
my $self = shift;
if ( @{ $self->{sql_array_out} } && $self->sql_fields_type eq 'array' ) {
return $self->{sql_array_out};
}
if ( $self->{sql_hash_out} && $self->sql_fields_type eq 'hash' ) {
return $self->{sql_hash_out};
}
}
sub error_valid {
my $self = shift;
return ( $self->{bad_array_out} || $self->{bad_hash_out} ) ? 1 : undef;
}
=head1 NAME
MyApp::Model::ExtraDBI - DBI Model Class
=head1 SYNOPSIS
See L<MyApp>
=head1 DESCRIPTION
DBI Model Class.
=head1 AUTHOR
Dmitriy
email: q7u5@ukr.net
=head1 LICENSE
This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
| как работает:
my ( $self, $c, $edit_co ) = @_;
$c->stash->{template} = 'add_section.tt';
my $f = $c->model('ExtraDBI')->new; # инициализируется класс
$f->all_fields_type('hash'); # определяется что возвращать
$f->bad_fields_type('array'); #
# $c->request->params-> хэш форм
$f->cut_xss( 'name_co', $c->request->params->{name_content} )->exist_die;
# Удаляется xss, первый элемент ключ, второй - значение
# дальше идет метод exist_die, если не определено значение,
# то возращает ошибку в массив
$f->cut_xss( 'heading_name_co', $c->request->params->{name_head_content} )
->exist_die;
$f->cut_xss( 'keys_co', $c->request->params->{content_keys} )->exist_die;
$f->cut_xss( 'text_co', $c->request->params->{content_text} )->exist_die;
if ( $c->check_user_roles("moder_se") ) {
# проверяется включен ли элемент HTML check, вкл 1, выкл 0
# и вставляться в хэш,
# дальше из него строиться SQL запрос, хэш отправляется в
# SQL::Abstarct
$f->int_check( 'hiden_g_co',
$c->request->params->{type_hiden_guest_content} );
$f->int_check( 'close_co', $c->request->params->{type_close_content} );
$f->int_check( 'active_co',
$c->request->params->{type_active_content} );
}
$f->int_check( 'hiden_co', $c->request->params->{type_hiden_content} );
$f->int_check( 'voting_co', $c->request->params->{type_voting_content} );
$f->int_check( 'forbi_comm_co', $c->request->params->{forbi_comm_co} );
my $sp;
if ( $c->request->params->{type_section_privat} eq 'on' ) {
$sp = 'AND privat_se = 1';
}
else {
$sp = 'AND privat_se = 0';
$f->no_sql->int_check( 'privat_se', 'on' );
}
if ( !$edit_co && !$c->request->params->{section_child2} ) {
$c->request->params->{section_child2} =
$c->request->params->{type_section_privat} eq '1' ? 1 : 35;
}
if (
$f->no_sql->valid_id(
# это действие в SQL запрос не идет,
# valid_id() если значение не цифра, то ошибка
'parent_se_id', $c->request->params->{section_child2}
)->out
)
{
my $dbh = $c->model('DBI')->dbh;
my $sth = $dbh->prepare(
"SELECT id_se,
id_un,
close_se,
active_se,
forbi_content_se,
privat_se
FROM section
WHERE id_se = ?
$sp
LIMIT 1"
);
$sth->execute( $c->request->params->{section_child2} );
my $section = $sth->fetchrow_hashref();
$sth->finish();
if ( $f->exist_die( 'id_se', $section->{id_se} )->out ) {
# если отсутствует - ошибка
if ( !$c->check_user_roles('moder_se') ) {
if ( $section->{active_se} == 0
&& $section->{id_un} != $c->user->{user}->{id} )
{
$f->no_sql->zero_die( 'active_se', 0 );
}
$f->no_sql->zero_die( 'forbi_content_se',
$section->{forbi_content_se} );
}
}
}
if ($edit_co) {
$f->no_sql->exist_die( 'no_edit_id_co',
$c->request->params->{edit_id_co} );
if ( !$c->check_user_roles('moder_se') ) {
my $dbh = $c->model('DBI')->dbh;
my $sth = $dbh->prepare(
"SELECT id_co,
close_co,
id_un
FROM content
WHERE id_co = ?
LIMIT 1"
);
$sth->execute( $c->request->params->{edit_id_co} );
my $section = $sth->fetchrow_hashref();
$sth->finish();
$f->no_sql->zero_die( 'close_co', $section->{close_se} );
if ( $section->{id_un} == $c->user->{user}->{id} ) {
$f->no_sql->zero_die( 'id_un_no_co', 0 );
}
}
}
# если найдена ошибка, то пропускает обработку СУБД
if ( !$f->error_valid ) {
# если ошибок нету
my $hash = $f->out_all; # получаем хэш SQL
my $type_sql;
my $where; # дополнительный хэш, условие SQL
if ($edit_co) {
# если текущее действие редактирование
$type_sql = 'update';
# sql действие для модуля SQL::Abstarct
$where->{id_co} = $c->request->params->{edit_id_co};
$where->{id_un} = $c->user->{user}->{id}
if ( !$c->check_user_roles('moder_co') );
$hash->{modified} = time;
}
if ( !$edit_co ) {
# аналогично, не редактирование
if ( !$c->check_user_roles("moder_se") ) {
$hash->{hiden_g_co} = 0;
$hash->{close_co} = 0;
$hash->{active_co} = 0;
}
$type_sql = 'insert';
$hash->{created} = time;
$hash->{id_un} = $c->user->{user}->{id};
}
use SQL::Abstract;
my $sql = SQL::Abstract->new;
# генерим запрос, таблица content
my ( $stmt, @bind ) = $sql->$type_sql( 'content', $hash, $where );
my $dbh = $c->model('DBI')->dbh;
my $sth = $dbh->prepare($stmt);
$sth->execute(@bind);
$sth->finish();
# выполнили
my $lastid = $dbh->{mysql_insertid} unless ($edit_co);
# последний элемент для редиректа
my $url;
# редиректим в зависимости от условия
my $redirect_id =
$edit_co ? $c->request->params->{edit_id_co} : $lastid;
if ( $c->request->params->{type_redirect} eq 'on' ) {
$url = '/profile/edit_pesonal_content/' . $redirect_id;
}
else {
$url = '/view_content/' . $redirect_id;
}
$c->response->redirect( $c->uri_for($url) );
$c->detach();
}
else {
# если была ошибка (которая не должна быть, иначе SQL запрос не сработает)
my $out_all = $f->out_all;
# получить все элементы, чтобы заполнить обратно формы ШТМЛ
my $out_bad = $f->out_bad;
# там где была ошибка
$c->stash->{bad_form} = 1;
# ошибка, $c->stash-> хэш который идет в шаблон HTML
while ( my ( $key, $value ) = each( %{$out_all} ) ) {
# ссылка на хэш и в шаблон
$c->stash->{ $key . '_current' } = $value;
}
foreach ( @{$out_bad} ) {
# все плохие эллементы, то же самое массив через ссылку
$_ .= $_ . '_error' if ( $_ eq 'id_se' );
$c->stash->{$_} = 1;
}
# возвращется обратно в зависимости редактирования или добавления
if ( !$edit_co ) {
$c->forward( 'add_content',
[ $c->request->params->{section_child2} ] );
}
else {
$c->forward( 'edit_pesonal_content',
[ $c->request->params->{section_child2} ] );
}
$c->detach();
}
| на счет экранирование тэгов от XSS, можно посмотреть на разные варианты, вот вариант взят с Ikonboard
sub _clean_html {
my $self = shift;
$self->{value} =~ s!\0!!g;
$self->{value} =~ s|&|&|g;
$self->{value} =~ s|<!--|<!--|g;
$self->{value} =~ s|-->|-->|g;
$self->{value} =~ s|<script|<script|ig;
$self->{value} =~ s|>|>|g;
$self->{value} =~ s|<|<|g;
$self->{value} =~ s|"|"|g;
$self->{value} =~ s| | |g;
$self->{value} =~ s!\|!|!g;
$self->{value} =~ s|\n|<br>|g;
$self->{value} =~ s|\$|$|g;
$self->{value} =~ s|\r||g;
$self->{value} =~ s|\_\_(.+?)\_\_||g;
$self->{value} =~ s|\\|\|g;
$self->{value} =~ s|\'|'|g;
$self->{value} =~ s|!|!|g;
return $self;
}
| ####
####
####
и пример из книге Джонатана Роквея “Catalyst”
используется: MVC Catatalyst, DBIx::Class, FormBuilder
package AddressBook::Controller::Address;
use strict;
use warnings;
use base qw(Catalyst::Controller::FormBuilder Catalyst::Controller::
BindLex');
sub add : Local Form('/address/edit') {
my ($self, $c, $person_id) = @_;
$c->stash->{template} = 'address/edit.tt2';
$c->forward('edit', [undef, $person_id]);
}
sub edit : Local Form {
my ($self, $c, $address_id, $person_id) = @_;
my $address : Stashed;
if(!$address_id && $person_id){
# we're adding a new address to $person
# check that person exists
my $person = $c->model('AddressDB::People')->
find({id => $person_id});
if(!$person){
$c->stash->{error} = 'No such person!';
$c->detach('/person/list');
}
# create the new address
$address = $c->model('AddressDB::Addresses')->
new({person => $person});
}
else {
$address = $c->model('AddressDB::Addresses')->
find({id => $address_id});
if(!$address){
$c->stash->{error} = 'No such address!';
$c->detach('/person/list');
}
}
if ($c->form->submitted && $c->form->validate){
# transfer data from form to database
$address->location($c->form->field('location'));
$address->postal ($c->form->field('postal' ));
$address->phone ($c->form->field('phone' ));
$address->email ($c->form->field('email' ));
$address->insert_or_update;
$c->stash->{message} =
($address_id > 0 ? 'Updated ' : 'Added new ').
'address for '. $address->person->name;
$c->detach('/person/list');
}
else {
# transfer data from database to form
if(!$address_id){
$c->stash->{message} = 'Adding a new address ';
}
else {
$c->stash->{message} = 'Updating an address ';
}
$c->stash->{message} .= ' for '. $address->person->name;
$c->form->field(name => 'location',
value => $address->location);
$c->form->field(name => 'postal',
value => $address->postal);
$c->form->field(name => 'phone',
value => $address->phone);
$c->form->field(name => 'email',
value => $address->email);
}
}
sub delete : Local {
my ($self, $c, $address_id) = @_;
my $address = $c->model('AddressDB::Addresses')->
find({id => $address_id});
if($address){
# "Deleted First Last's Home address"
$c->stash->{message} =
'Deleted ' . $address->person->name. q{'s }.
$address->location. ' address';
$address->delete;
}
else {
$c->stash->{error} = 'No such address';
}
$c->forward('/person/list');
}
1;
| зеркало
www.x0.org.ua
Ссылка на обсуждение: http://forum.lissyara.su/viewtopic.php?f=14&t=16847.
|
размещено: 2009-07-18,
последнее обновление: 2010-05-15,
автор: ProFTP
|
|
|
|
2014-07-27, lissyara
gmirror
Удалённое создание софтверного зеркала средствами gmirror, на диске разбитом с использованием gpart. Использование меток дисков для монтирования разделов.
2013-08-20, zentarim
Scan+Print server FreeBSD 9
Настройка сервера печати и сервера сканирования под управлением операционной системы FreebSD 9 для МФУ Canon PIXMA MP540
2011-11-20, BlackCat
Разъём на WiFi-карту
Делаем съёмной несъёмную антену на WiFi-карте путём установки ВЧ-разъёма
2011-09-14, manefesto
Настройка git+gitosis
Настройка системы контроля версия исходного кода в связке git+gitosis+ssh
|
Комментарии пользователей [2 шт.]