В данной статье рассматривается реализация 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!!!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: rtyug@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!!!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;
зеркало