App-Dochazka-Common

 view release on metacpan or  search on metacpan

lib/App/Dochazka/Common/Model.pm  view on Meta::CPAN

Given a list of attributes, returns a ready-made 'filter' routine
which takes a PROPLIST and returns a new PROPLIST from which all bogus
properties have been removed.

=cut

sub make_filter {

    # take a list consisting of the names of attributes that the 'filter'
    # routine will retain -- these must all be scalars
    my ( @attr ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        if ( @_ % 2 ) {
            die "Odd number of parameters given to filter routine!";
        }
        my %ARGS = @_;
        my %PROPLIST;
        map { $PROPLIST{$_} = $ARGS{$_}; } @attr;
        return %PROPLIST;
    }

lib/App/Dochazka/Common/Model.pm  view on Meta::CPAN

=head2 make_reset

Given a list of attributes, returns a ready-made 'reset' method. 

=cut

sub make_reset {

    # take a list consisting of the names of attributes that the 'reset'
    # method will accept -- these must all be scalars
    my ( @attr ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    # construct the validation specification for the 'reset' routine:
    # 1. 'reset' will take named parameters _only_
    # 2. only the values from @attr will be accepted as parameters
    # 3. all parameters are optional (indicated by 0 value in $val_spec)
    my $val_spec;
    map { $val_spec->{$_} = 0; } @attr;
    
    return sub {
        # process arguments
        my $self = shift;
        #confess "Not an instance method call" unless ref $self;
        my %ARGS;
        %ARGS = validate( @_, $val_spec ) if @_ and defined $_[0];

        # Set attributes to run-time values sent in argument list.
	# Attributes that are not in the argument list will get set to undef.
        map { $self->{$_} = $ARGS{$_}; } @attr;

        # run the populate function, if any
        $self->populate() if $self->can( 'populate' );

        # return an appropriate throw-away value
        return;

lib/App/Dochazka/Common/Model.pm  view on Meta::CPAN

Returns a ready-made accessor.

=cut

sub make_accessor {
    my ( $subname, $type ) = @_;
    $type = $type || { type => SCALAR | UNDEF, optional => 1 };
    sub {
        my $self = shift;
        validate_pos( @_, $type );
        $self->{$subname} = shift if @_;
        $self->{$subname} = undef unless exists $self->{$subname};
        return $self->{$subname};
    };
}


=head2 make_TO_JSON

Returns a ready-made TO_JSON

=cut

sub make_TO_JSON {

    my ( @attr ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        my $self = shift;
        my $unblessed_copy;

        map { $unblessed_copy->{$_} = $self->{$_}; } @attr;

        return $unblessed_copy;
    }
}


=head2 make_compare

Returns a ready-made 'compare' method that can be used to determine if two objects are the same.

=cut

sub make_compare {

    my ( @attr ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        my ( $self, $other ) = validate_pos( @_, 1, 1 );
        return if ref( $other ) ne ref( $self );
        
        return eq_deeply( $self, $other );
    }
}


=head2 make_compare_disabled

Returns a ready-made 'compare' method that can be used to determine if two objects are the same.
For use with objects containing a 'disabled' property where 'undef' and 'false' are treatd
as functionally the same.

=cut

sub make_compare_disabled {

    my ( @attr ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        my ( $self, $other ) = validate_pos( @_, 1, 1 );
        return $self->compare( $other) unless grep { $_ eq 'disabled' } @attr;
        return if ref( $other ) ne ref( $self );
        my $self_disabled = $self->{'disabled'};
        delete $self->{'disabled'};
        my $other_disabled = $other->{'disabled'};
        delete $other->{'disabled'};
        return 0 unless eq_deeply( $self, $other );
        return 0 unless ( ! $self_disabled and ! $other_disabled ) or ( $self_disabled and $other_disabled );
        return 1;
    }

lib/App/Dochazka/Common/Model.pm  view on Meta::CPAN

=head2 make_clone

Returns a ready-made 'clone' method.

=cut

sub make_clone {

    my ( @attr ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        my ( $self ) = @_;

        my ( %h, $clone );
        map { $h{$_} = $self->{$_}; } @attr;
        {
            no strict 'refs';
            $clone = ( ref $self )->spawn( %h );
        }

lib/App/Dochazka/Common/Model.pm  view on Meta::CPAN

=head2 make_attrs

Returns a ready-made 'attrs' method.

=cut

sub make_attrs {

    my ( @attrs ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        my ( $self ) = @_;

        return \@attrs;
    }
}


=head2 make_get

Returns a ready-made 'get' method.

=cut

sub make_get {

    my ( @attrs ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        my ( $self, $attr ) = @_;

        if ( grep { $_ eq $attr } @attrs ) {
            return $self->{$attr};
        }
        # unknown attribute
        return;
    }

lib/App/Dochazka/Common/Model.pm  view on Meta::CPAN

=head2 make_set

Returns a ready-made 'set' method, which takes the name of an attribute and a
value to set that attribute to. Returns true value on success, false on failure.

=cut

sub make_set {

    my ( @attrs ) = validate_pos( @_, map { { type => SCALAR }; } @_ );

    return sub {
        my ( $self, $attr, $value ) = @_;

        if ( grep { $_ eq $attr } @attrs ) {
            $self->{$attr} = $value;
            return 1;
        }
        # unknown attribute
        return 0;