Форум программистов [Powered by Invision Power Board]

Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Perl: Общие вопросы > 'Class::Accessor

Автор: gcc 8.4.2009, 01:04

Код


__PACKAGE__->mk_accessors(qw(filename));

поясните что это за строка? и в чем смысл? не могу понять оно какие-то медоты инициализирует от куда-то?

Код


# Post.pm
package Blog::Model::Filesystem::Post;
use strict;
use warnings;
use Carp;
use File::Basename;
use File::Slurp qw(read_file);
use File::CreationTime qw(creation_time);
use base 'Class::Accessor';
__PACKAGE__->mk_ro_accessors(qw(filename));
sub new {
    my $class     = shift;
    my $filename = shift;
    croak "Must specify a filename" unless $filename;
    my $self = {};
    $self->{filename} = $filename;
    bless $self, $class;
    return $self;
}
sub title {
    my $self      = shift;
    my $filename = $self->filename;
    my $title     = basename($filename);
    $title        =~ s/[.](\w+)$//; # strip off .extensions
    return $title;
}
sub body {
    my $self = shift;
    return read_file($self->filename);
}
sub created {
    my $self = shift;
    return creation_time($self->filename);
}
sub modified {
    my $self = shift;
    return (stat $self->filename)[9]; # 9 is mtime
}
1;

Автор: arto 8.4.2009, 02:09

perldoc perldata

Автор: gcc 8.4.2009, 02:32

Цитата(arto @ 8.4.2009, 02:09)

perldoc perldata

полезная информация, но по сабжу там не нашел, а в документации модуля Class::Accessor наверное что-то не так перевел с анлийского

вот не много другое чем в примере до этого, в чем смысл этой записи?

Автор: arto 8.4.2009, 08:45

# perldoc perldata
...
Special Literals

       The special literals __FILE__, __LINE__, and __PACKAGE__ represent the current filename, line
       number, and package name at that point in your program.  They may be used only as separate tokens;
       they will not be interpolated into strings.  If there is no current package (due to an empty
       "package;" directive), __PACKAGE__ is the undefined value.
...

Автор: NuINu 8.4.2009, 09:47

Цитата(gcc @ 7.4.2009, 23:04

)

__PACKAGE__->mk_accessors(qw(filename));

это не соответствует коду который в классе, смотри внимательнее там:

Цитата(gcc @ 7.4.2009, 23:04

)

__PACKAGE__->mk_ro_accessors(qw(filename));

создает метод filename позволяющий читать поле filename

тобишь $post->filename
используется для упрощения конструкции $post->{'filename'}
при этом данное обявление не позволяет изменять значение этого поля.

зы: эскперименты не приводил, так что попробуй сам.

Автор: gcc 9.4.2009, 05:17

arto, извените я не правильно задал вопрос, мне надо было mk_accessors(qw(filename)); я сначало не понял в каких ситуациях оно лучше

NuINu, вроде бы разобраля

Автор: gcc 9.4.2009, 18:43

нет, не понял

пакет:

Код


package DBIxTreeOut;

use DBIx::Tree;

# use strict;
use warnings;

use base qw(Class::Accessor);

__PACKAGE__->mk_accessors(qw/sql dbh startid/);

# use lib "/home/x0/data/www/MyApp/lib/MyApp/Model";

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    return $self;
}


sub out_tree {

my $self = shift;

my $sql = $self->sql;

my $dbh = $self->dbh;

$startid =  $self->startid;

......................

вызывается:

Код


package MyApp::Controller::view_tree;


use warnings;
use parent 'Catalyst::Controller';

use strict;

use lib "/home/x0/data/www/MyApp/lib/MyApp/module";

require DBIxTreeOut;

=head1 NAME

MyApp::Controller::view_tree - Catalyst Controller

=head1 DESCRIPTION

Catalyst Controller.

=head1 METHODS

=cut


=head2 index 

=cut

sub view_tree : Global {
    my ( $self, $c, @args ) = @_;

    $c->stash->{template} = 'view_tree.tt';
    


my $sql;
if (defined($args[0])) {

$sql = "SELECT id_se, name_se, parent_se_id
        FROM section
        WHERE active_se = 1 AND privat_se = 0
";

} else { 

 $sql = "SELECT id_se, name_se, parent_se_id
         FROM section
         WHERE active_se = 1 AND privat_se = 0
";

}

my $dbh = $c->model('DBI')->dbh;



my $out_tree = new DBIxTreeOut();
my $out_tree->sql($sql);

my $out_tree->dbh($dbh);

my $out_tree->startid($args[0]);

my $tree_a = $out_tree->out_tree();

       $c->stash->{tree} = $tree_a;

}

пишет:
"Can't call method "sql"
метода sql нету

вот не много только есть:
http://perladvent.pm.org/2004/3rd/
http://kiev.pm.org/node/219

Автор: NuINu 9.4.2009, 18:59

ну внимательней смотри

Код


my $out_tree->sql($sql);

ты же переопределил переменную.

Автор: gcc 23.4.2009, 10:37

сейчас решил не много переделать по другому свой класс для валидации форм

(perltidy)

Код


package MyApp::Model::ExtraDBI;

use strict;
use warnings;

use base qw( Catalyst::Model Class::Accessor::Fast );

use NEXT;

__PACKAGE__->mk_accessors(qw/out_all bad_fields_type all_fields_type valid_id/);

sub new {
    my ( $self, $c ) = @_;
    $self = $self->NEXT::new(@_);
}

####
#   Add out fields
###

sub _add_bad_fields {
    my ( $self, $text ) = @_;

    if ( $self->bad_fields_type eq 'arrey' ) {

        my @arey_out;
        push @arey_out, $text;    # is $self->fails_type  arrey

    }
    elsif ( $self->bad_fields_type eq 'hash' ) {

        # my $hash_out;
        $self->{hash_out}->{$text} =
          $self->$text;    # $self->fails_type  HASH   key = faild, value = name
    }

}

sub _add_all_fields {
    my ( $self, $text ) = @_;

    if ( $self->all_fields_type eq 'arrey' ) {
        my @arey_out;
        push @arey_out, $text;    # is $self->fails_type  arrey
    }
    elsif ( $self->all_fields_type eq 'hash' ) {

        #    my $hash_out;
        $self->{hash_out}->{$text} =
          $self->$text;    # $self->fails_type  HASH   key = faild, value = name
    }

    # return;

}

####
#   Clean text, remove bad tag, etc
###

sub _del_blanks_end_began {
    my ( $self, $text ) = @_;

    $self->$text =~ s/^\s+//;
    $self->$text =~ s/\s+$//;

}

sub cleaning_ {
    my $self = shift;

}

####
#   Valid fields
###

sub valid_id {
    my $self = shift;

    my $valid_id = $self->valid_id;

    $self->_add_all_fields( $valid_id, 'valid_id' );

    $self->valid_id = $self->_del_blanks_end_began('valid_id');

    if ( $self->valid_id =~ /^\d+$/ ) {
        return;
    }
    else {
        $self->valid_id = $self->_add_bad_fields( $self->valid_id, 'valid_id' );
        return 0;
    }

}

sub out_all {
    my $self = shift;

    # if (!$self->out_all) {
    # return 0;
    # }

    #@if (defined $self->{hash_out}) {
    return $self->{hash_out};

    #}

}

вызываю так:

Код


 my $f = $c->model('ExtraDBI')->new;
   
    $f->valid_id( $ps->{name_section} );
........................................................

ругается:

Код


Deep recursion on subroutine "MyApp::Model::ExtraDBI::valid_id" at
 /home/data/www/MyApp/script/../lib/MyApp/Model/ExtraDBI.pm line 78.

на строку:

Код


my $valid_id = $self->valid_id;

из:

Код


sub valid_id {
my $self = shift;

my $valid_id = $self->valid_id;

    $self->_add_all_fields($valid_id,'valid_id');

как тут можно по другому написать? или без Class::Accessor надо?

как только закомментировать my $valid_id = $self->valid_id; то работает

Автор: gcc 23.4.2009, 12:20

сделал
вроде бы работает

там нельзя наверное чтобы метод назывался так как ассесор

Код


sub valid_id {
my ($self, $value) = shift;

#my $valid_id = $self->valid_id;

  $self->{value} = $value; 

    $self->_add_all_fields($self->{value},'valid_id');

    $self->{value} = $self->_del_blanks_end_began('valid_id');

    if ($self->valid_id =~ /^\d+$/) {
        return;
    } else {                
        $self->{value} = $self->_add_bad_fields($self->{value},'valid_id');        
    return 0;        
    }

}

Автор: ginnie 23.4.2009, 14:15

gcc, открою страшную тайну: аксессор - тоже метод, в Perl, конечно, два разных метода в одном пространстве имен одинаковое имя иметь не могут.

Автор: gcc 22.7.2009, 02:44

нашел полезные вещи с Class::Accessor

только это Class::Data::Inheritable

жалко раньше не видел подобого...

Код



package Catalyst::Plugin::Session::Store::DBI;

use strict;
use warnings;
use base qw/Class::Data::Inheritable Catalyst::Plugin::Session::Store/;
use DBI;
use MIME::Base64;
use NEXT;
use Storable qw/nfreeze thaw/;

our $VERSION = '0.13';

__PACKAGE__->mk_classdata('_session_sql');
__PACKAGE__->mk_classdata('_session_dbh');
__PACKAGE__->mk_classdata('_sth_get_session_data');
__PACKAGE__->mk_classdata('_sth_get_expires');
__PACKAGE__->mk_classdata('_sth_check_existing');
__PACKAGE__->mk_classdata('_sth_update_session');
__PACKAGE__->mk_classdata('_sth_insert_session');
__PACKAGE__->mk_classdata('_sth_update_expires');
__PACKAGE__->mk_classdata('_sth_delete_session');
__PACKAGE__->mk_classdata('_sth_delete_expired_sessions');

Код



    # Pre-generate all SQL statements
    my $table = $c->config->{session}->{dbi_table};
    $c->_session_sql( {
        get_session_data        =>
            "SELECT session_data FROM $table WHERE id = ?",
        get_expires             =>
            "SELECT expires FROM $table WHERE id = ?",
        check_existing          =>
            "SELECT 1 FROM $table WHERE id = ?",
        update_session          =>
            "UPDATE $table SET session_data = ?, expires = ? WHERE id = ?",
        insert_session          =>
            "INSERT INTO $table (session_data, expires, id) VALUES (?, ?, ?)",
        update_expires          =>
            "UPDATE $table SET expires = ? WHERE id = ?",
        delete_session          =>
            "DELETE FROM $table WHERE id = ?",
        delete_expired_sessions =>
            "DELETE FROM $table WHERE expires IS NOT NULL AND expires < ?",
    } );

Код


# Prepares SQL statements as needed
sub _session_sth {
    my ( $c, $key ) = @_;

    if ( my $sql = $c->_session_sql->{$key} ) {
        my $accessor = "_sth_$key";
        
        if ( defined $c->$accessor ) {
            
            # Check for the 'morning bug', where the dbh may have gone away
            # while we still have cached sth's using it.
            if ( $c->$accessor->{Database} ne $c->_session_dbh ) {
                # The sth has an old dbh, so we need to prepare it again
                if ( $c->$accessor->{Active} ) {
                    $c->$accessor->finish;
                }
            }
            else {
                return $c->$accessor;
            }
        }
        
        return $c->$accessor( $c->_session_dbh->prepare( $sql ) );
    }
    
    return;
}

# close any active sth's to avoid warnings
sub DESTROY {
    my $c = shift;
    $c->NEXT::DESTROY(@_);
    
    for my $key ( keys %{ $c->_session_sql } ) {
        my $accessor = "_sth_$key";
        if ( defined $c->$accessor && $c->$accessor->{Active} ) {
            $c->$accessor->finish;
        }
    }
}

1;
__END__