view release on metacpan or  search on metacpan

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

=head2 make_filter

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;
    }
}


=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;
    }
}


=head2 make_accessor

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 );