Реализация CRUD + SQL::Abstract на Perl (в MVC Catalyst) Perl обработка данных форм виртуальные построители html Perl mod_perl построение установка настройка Perl инсталяция модулей Comprehensive Perl Archive Network модули Perl mod_perl основы Apache PERL шаблоны html программирование Sub-Categories ActionScript ASP ASP.Net Bash Batch Actions C# C/C++ Character ColdFusion Command Prompt C# CSS CSV Database Delphi DHTML DocBook Drag and Drop Editor Files Flash Functions hkScript HKPGen Definition HTML iHTML INI Java JavaScript JScript JSP MathML Misc Online P3P Page Wizards PDA Perl PHP Preview Programming Python Reference Regex Right Click Menu Ruby Security SMIL Source Splash Screens SQL SSI SVG Text Translations Validators VBScript Visual Basic Voice VRML WAP WinBatch Wizards WML WMLScript Workspace X3D XForms XHTML XML XSL XSLT XWT Разработк

"satan666 251" by ProFTP
"satan666 250" by ProFTP
"satan666 249" by ProFTP
"satan666 248" by ProFTP
"satan666 247" by ProFTP
"satan666 246" by ProFTP
"satan666 245" by ProFTP
"satan666 244" by ProFTP
"satan666 243" by ProFTP
"satan666 235" by ProFTP
Остальные

Новые фотографии:



































































































Рейтинг фотографий

Новые видео клипы:

























Рейтинг видео клипов

Навигационная панель

В чате сейчас: 0 человек >>

Сообщений без ответа: 0 >>

Дополнительные функции доступные только зарегистрированным пользователям!

Можете зарегистрироваться

Новости и важные обсуждения

Идея групп (клубов, социальных сетей) >>

Чат (функциональность, технологии) >>

Новости проекта, разработки

Знакомства (движок, компонент, пример) >>

Панель

Просмотр темы

Главная -->

Компьютеры -->

Интернет -->

Программирование -->

PERL -->

« Предыдущий контент Следующий контент »

На уровень выше

Посмотреть подразделы

Тема: CRUD Perl Web (Просмотров: 11493)

Автор: ProFTP

Дата: 1261211026

Новое: 1261375373

Посмотреть комментарии этой темы

Реализация CRUD + SQL::Abstract на Perl (в MVC Catalyst)

В данной статье рассматривается реализация CRUD под perl. Все кто программируют под web знают, что главная проблема веб программирования обработать HTML form тэги (<form></form>) и при этом работать с БД (как правило с различными СУБД), что в некоторых случаях бывает затруднительно. CRUD - (англ. create read update delete — «Создание чтение обновление удаление»): Code: Операция 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. Code: 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|<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; как работает: Code: 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 Code: sub _clean_html { my $self = shift; $self->{value} =~ s!\0!!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 Code: 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; зеркало

Проголосовавшых: 4 Балов: 25 Среднее: 6.25 Популярность: 2

Чтобы проголосовать вы должны зарегистрироватся !

Группы:

Групп не найдено!

Фотоальбомы:

Фотоальбомов не найдено

Видеоальбомы:

Видеоальбомов не найдено

test02 :: :: :: 1261212616 :: ссылка :: ::
UPD: обновил
test02 :: :: :: 1261213299 :: ссылка :: ::
обновил еще, может еще написать? тест
ProFTP :: :: :: 1261389842 :: ссылка :: ::
тест тесттест тест тест тест
ProFTP :: :: :: 1261389847 :: ссылка :: ::
тест тесттест тест тест тест
ProFTP :: :: :: 1261389852 :: ссылка :: ::
тест тесттест тест тест тест
ProFTP :: :: :: 1261389871 :: ссылка :: ::
тест тесттест тест тест тест
ProFTP :: :: :: 1261389885 :: ссылка :: ::
тест тесттест тест тест тест
ProFTP :: :: :: 1261389891 :: ссылка :: ::
тест тесттест тест тест тест
ProFTP :: :: :: 1261389898 :: ссылка :: ::
тест тесттест тест тест тест
ProFTP :: :: :: 1261389904 :: ссылка :: ::
тест тесттест тест тест тест0

Гостям, запрещено создавать комментарии! Можете зарегистрироватся ...

HTML/CSS/JS has been tested in a browser Firefox2-3, secondary - IE.

BETA testing, Lite version. MVC Catalyst, Perl, jQuery UI/Plugins, CSS3, MySQL, FreeBSD, etc. Open source (email: q7u5@ukr.net)

Навигационная панель

Новости и важные обсуждения

Просмотр темы

Комментарии