Мы — долго запрягаем, быстро ездим, и сильно тормозим.
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!\|!&#124;!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|&|&amp;|g;
    $self->{value} =~ s|<!--|&#60;&#33;--|g; 
    $self->{value} =~ s|-->|--&#62;|g; 
    $self->{value} =~ s|<script|&#60;script|ig; 
    $self->{value} =~ s|>|&gt;|g;
    $self->{value} =~ s|<|&lt;|g;
    $self->{value} =~ s|"|&quot;|g; 
    $self->{value} =~ s|  | &nbsp;|g; 
    $self->{value} =~ s!\|!&#124;!g; 
    $self->{value} =~ s|\n|<br>|g; 
    $self->{value} =~ s|\$|&#36;|g; 
    $self->{value} =~ s|\r||g; 
    $self->{value} =~ s|\_\_(.+?)\_\_||g; 
    $self->{value} =~ s|\\|&#92;|g; 
    $self->{value} =~ s|\'|&#39;|g; 
    $self->{value} =~ s|!|&#33;|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



размещено: 2009-07-18,
последнее обновление: 2010-05-15,
автор: ProFTP


Комментарии пользователей [2 шт.]

adre, 2009-08-10 в 10:26:32

Это для сохранение данных формы при не верном заполнении или че-то не понятно, комплексное обслуживаение запросов пользователия и доставания ему нужной информации??

ProFTP, 2009-09-27 в 5:27:47

да, именно для этого...

я решил написать класс без ORM, а для абcтаркции SQL (SQL::Abstract)
 

  Этот информационный блок появился по той простой причине, что многие считают нормальным, брать чужую информацию не уведомляя автора (что не так страшно), и не оставляя линк на оригинал и автора — что более существенно. Я не против распространения информации — только за. Только условие простое — извольте подписывать автора, и оставлять линк на оригинальную страницу в виде прямой, активной, нескриптовой, незакрытой от индексирования, и не запрещенной для следования роботов ссылки.
  Если соизволите поставить автора в известность — то вообще почёт вам и уважение.

© lissyara 2006-10-24 08:47 MSK

Время генерации страницы 0.0816 секунд
Из них PHP: 64%; SQL: 36%; Число SQL-запросов: 77 шт.
Исходный размер: 62665; Сжатая: 12871