accessor.pm

来自「视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.」· PM 代码 · 共 751 行 · 第 1/2 页

                                            # of 'some_accessor'

See the C<SYNOPSIS> for more examples.

=cut

### custom 'can' as UNIVERSAL::can ignores autoload
sub can {
    my($self, $method) = @_;

    ### it's one of our regular methods
    if( $self->UNIVERSAL::can($method) ) {
        __PACKAGE__->___debug( "Can '$method' -- provided by package" );
        return $self->UNIVERSAL::can($method);
    }

    ### it's an accessor we provide;
    if( UNIVERSAL::isa( $self, 'HASH' ) and exists $self->{$method} ) {
        __PACKAGE__->___debug( "Can '$method' -- provided by object" );
        return sub { $self->$method(@_); }
    }

    ### we don't support it
    __PACKAGE__->___debug( "Cannot '$method'" );
    return;
}

### don't autoload this
sub DESTROY { 1 };

### use autoload so we can have per-object accessors,
### not per class, as that is incorrect
sub AUTOLOAD {
    my $self    = shift;
    my($method) = ($AUTOLOAD =~ /([^:']+$)/);

    my $val = $self->___autoload( $method, @_ ) or return;

    return $val->[0];
}

sub ___autoload {
    my $self    = shift;
    my $method  = shift;
    my $assign  = scalar @_;    # is this an assignment?

    ### a method on our object
    if( UNIVERSAL::isa( $self, 'HASH' ) ) {
        if ( not exists $self->{$method} ) {
            __PACKAGE__->___error("No such accessor '$method'", 1);
            return;
        } 
   
    ### a method on something else, die with a descriptive error;
    } else {     
        local $FATAL = 1;
        __PACKAGE__->___error( 
                "You called '$AUTOLOAD' on '$self' which was interpreted by ".
                __PACKAGE__ . " as an object call. Did you mean to include ".
                "'$method' from somewhere else?", 1 );
    }        

    ### assign?
    my $val = $assign ? shift(@_) : $self->___get( $method );

    if( $assign ) {

        ### any binding?
        if( $_[0] ) {
            if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {
            
                ### tie the reference, so we get an object and
                ### we can use it's going out of scope to restore
                ### the old value
                my $cur = $self->{$method}->[VALUE];
                
                tie ${$_[0]}, __PACKAGE__ . '::TIE', 
                        sub { $self->$method( $cur ) };
    
                ${$_[0]} = $val;
            
            } else {
                __PACKAGE__->___error( 
                    "Can not bind '$method' to anything but a SCALAR", 1 
                );
            }
        }
        
        ### need to check the value?
        if( exists $self->{$method}->[ALLOW] ) {

            ### double assignment due to 'used only once' warnings
            local $Params::Check::VERBOSE = 0;
            local $Params::Check::VERBOSE = 0;
            
            allow( $val, $self->{$method}->[ALLOW] ) or (
                __PACKAGE__->___error( 
                    "'$val' is an invalid value for '$method'", 1), 
                return 
            ); 
        }
    }
    
    ### callbacks?
    if( my $sub = $self->___callback ) {
        $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
        
        ### register the error
        $self->___error( $@, 1 ), return if $@;
    }

    ### now we can actually assign it
    if( $assign ) {
        $self->___set( $method, $val ) or return;
    }
    
    return [$val];
}

=head2 $val = $self->___get( METHOD_NAME );

Method to directly access the value of the given accessor in the
object. It circumvents all calls to allow checks, callbakcs, etc.

Use only if you C<Know What You Are Doing>! General usage for 
this functionality would be in your own custom callbacks.

=cut

### XXX O::A::lvalue is mirroring this behaviour! if this
### changes, lvalue's autoload must be changed as well
sub ___get {
    my $self    = shift;
    my $method  = shift or return;
    return $self->{$method}->[VALUE];
}

=head2 $bool = $self->___set( METHOD_NAME => VALUE );

Method to directly set the value of the given accessor in the
object. It circumvents all calls to allow checks, callbakcs, etc.

Use only if you C<Know What You Are Doing>! General usage for 
this functionality would be in your own custom callbacks.

=cut 

sub ___set {
    my $self    = shift;
    my $method  = shift or return;
   
    ### you didn't give us a value to set!
    exists $_[0] or return;
    my $val     = shift;
 
    ### if there's more arguments than $self, then
    ### replace the method called by the accessor.
    ### XXX implement rw vs ro accessors!
    $self->{$method}->[VALUE] = $val;

    return 1;
}

sub ___debug {
    return unless $DEBUG;

    my $self = shift;
    my $msg  = shift;
    my $lvl  = shift || 0;

    local $Carp::CarpLevel += 1;
    
    carp($msg);
}

sub ___error {
    my $self = shift;
    my $msg  = shift;
    my $lvl  = shift || 0;
    local $Carp::CarpLevel += ($lvl + 1);
    $FATAL ? croak($msg) : carp($msg);
}

### objects might be overloaded.. if so, we can't trust what "$self"
### will return, which might get *really* painful.. so check for that
### and get their unoverloaded stringval if needed.
sub ___callback {
    my $self = shift;
    my $sub  = shift;
    
    my $mem  = overload::Overloaded( $self )
                ? overload::StrVal( $self )
                : "$self";

    $self->{$mem} = $sub if $sub;
    
    return $self->{$mem};
}

=head1 LVALUE ACCESSORS

C<Object::Accessor> supports C<lvalue> attributes as well. To enable
these, you should create your objects in the designated namespace,
C<Object::Accessor::Lvalue>. For example:

    my $obj = Object::Accessor::Lvalue->new('foo');
    $obj->foo += 1;
    print $obj->foo;
    
will actually print C<1> and work as expected. Since this is an
optional feature, that's not desirable in all cases, we require
you to explicitly use the C<Object::Accessor::Lvalue> class.

Doing the same on the standard C<Object>>Accessor> class would
generate the following code & errors:

    my $obj = Object::Accessor->new('foo');
    $obj->foo += 1;

    Can't modify non-lvalue subroutine call

Note that C<lvalue> support on C<AUTOLOAD> routines is a
C<perl 5.8.x> feature. See perldoc L<perl58delta> for details.

=head2 CAVEATS

=over 4

=item * Allow handlers

Due to the nature of C<lvalue subs>, we never get access to the
value you are assigning, so we can not check it againt your allow
handler. Allow handlers are therefor unsupported under C<lvalue>
conditions.

See C<perldoc perlsub> for details.

=item * Callbacks

Due to the nature of C<lvalue subs>, we never get access to the
value you are assigning, so we can not check provide this value
to your callback. Furthermore, we can not distinguish between
a C<get> and a C<set> call. Callbacks are therefor unsupported 
under C<lvalue> conditions.

See C<perldoc perlsub> for details.


=cut

{   package Object::Accessor::Lvalue;
    use base 'Object::Accessor';
    use strict;
    use vars qw[$AUTOLOAD];

    ### constants needed to access values from the objects
    *VALUE = *Object::Accessor::VALUE;
    *ALLOW = *Object::Accessor::ALLOW;

    ### largely copied from O::A::Autoload 
    sub AUTOLOAD : lvalue {
        my $self    = shift;
        my($method) = ($AUTOLOAD =~ /([^:']+$)/);

        $self->___autoload( $method, @_ ) or return;

        ### *dont* add return to it, or it won't be stored
        ### see perldoc perlsub on lvalue subs
        ### XXX can't use $self->___get( ... ), as we MUST have
        ### the container that's used for the lvalue assign as
        ### the last statement... :(
        $self->{$method}->[ VALUE() ];
    }

    sub mk_accessors {
        my $self    = shift;
        my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' );
        
        $self->___error(
            "Allow handlers are not supported for '". __PACKAGE__ ."' objects"
        ) if $is_hash;
        
        return $self->SUPER::mk_accessors( @_ );
    }                    
    
    sub register_callback {
        my $self = shift;
        $self->___error(
            "Callbacks are not supported for '". __PACKAGE__ ."' objects"
        );
        return;
    }        
}    


### standard tie class for bound attributes
{   package Object::Accessor::TIE;
    use Tie::Scalar;
    use Data::Dumper;
    use base 'Tie::StdScalar';

    my %local = ();

    sub TIESCALAR {
        my $class   = shift;
        my $sub     = shift;
        my $ref     = undef;
        my $obj     =  bless \$ref, $class;

        ### store the restore sub 
        $local{ $obj } = $sub;
        return $obj;
    }
    
    sub DESTROY {
        my $tied    = shift;
        my $sub     = delete $local{ $tied };

        ### run the restore sub to set the old value back
        return $sub->();        
    }              
}

=head1 GLOBAL VARIABLES

=head2 $Object::Accessor::FATAL

Set this variable to true to make all attempted access to non-existant
accessors be fatal.
This defaults to C<false>.

=head2 $Object::Accessor::DEBUG

Set this variable to enable debugging output.
This defaults to C<false>.

=head1 TODO

=head2 Create read-only accessors

Currently all accessors are read/write for everyone. Perhaps a future
release should make it possible to have read-only accessors as well.

=head1 CAVEATS

If you use codereferences for your allow handlers, you will not be able
to freeze the data structures using C<Storable>.

Due to a bug in storable (until at least version 2.15), C<qr//> compiled 
regexes also don't de-serialize properly. Although this bug has been 
reported, you should be aware of this issue when serializing your objects.

You can track the bug here: 

    http://rt.cpan.org/Ticket/Display.html?id=1827

=head1 AUTHOR

This module by
Jos Boumans E<lt>[e-mail]<gt>.

=head1 COPYRIGHT

This module is
copyright (c) 2004-2005 Jos Boumans E<lt>[e-mail]<gt>.
All rights reserved.

This library is free software;
you may redistribute and/or modify it under the same
terms as Perl itself.

=cut

1;