File Coverage

blib/lib/Prophet/Record.pm

Criterion	Covered	Total	%
statement	21	244	8.6
branch	0	72	0.0
condition	0	25	0.0
subroutine	7	54	12.9
pod	30	34	88.2
total	58	429	13.5

package Prophet::Record;
use Any::Moose;
use Params::Validate;
use Prophet::App; # for require_module. Kinda hacky
use constant collection_class => 'Prophet::Collection';

=head1 NAME

Prophet::Record

=head1 DESCRIPTION

This class represents a base class for any record in a Prophet database.

=cut

has app_handle => (
    isa      => 'Prophet::App|Undef',
    is       => 'rw',
    required => 0,
);

has handle => (
    is       => 'rw',
    required => 1,
    default => sub { shift->app_handle->handle }
);

has type => (
    is        => 'rw',
    isa       => 'Str',
    predicate => 'has_type',
    required => 1,
    default   => sub { undef}
);

has uuid => (
    is      => 'rw',
    isa     => 'Str',
);

has luid => (
    is  => 'rw',
    isa => 'Str|Undef',
    lazy => 1,
    default => sub { my $self = shift; $self->find_or_create_luid; },
);

our $REFERENCES = {};
sub REFERENCES { $REFERENCES }

our $PROPERTIES = {};
sub PROPERTIES { $PROPERTIES }

=head1 METHODS

=head2 new  { handle => Prophet::Replica, type => $type }

Instantiates a new, empty L of type $type.

=head2 declared_props

Returns a sorted list of the names of the record's declared properties.
Declared properties are always validated even if the user provides no value
for that prop. This can be used for such things as requiring records to
have certain props in order to be created, for example.

=cut

sub declared_props {
    return sort keys %{ $_[0]->PROPERTIES };
}

=head2 record_type

Returns the record's type.

=cut

sub record_type { $_[0]->type }

=head2 register_reference $class, $accessor, $foreign_class, @args

Registers a reference to a foreign class to this record. The
foreign class must be of type L or
L, or else a fatal error is triggered.

=cut

sub register_reference {
    my ( $class, $accessor, $foreign_class, @args ) = @_;
    Prophet::App->require($foreign_class);
    if ( $foreign_class->isa('Prophet::Collection') ) {
        return $class->register_collection_reference(
            $accessor => $foreign_class,
            @args
        );
    } elsif ( $foreign_class->isa('Prophet::Record') ) {
        return $class->register_record_reference(
            $accessor => $foreign_class,

            # default the lookup property to be the name of the accessor
            by        => $accessor,

            @args
        );
    } else {
        die "Your foreign class ($foreign_class) must be a subclass of Prophet::Record or Prophet::Collection";
    }

}

=head2 register_collection_reference $accessor, $collection_class, by => $key_in_model

Registers and creates an accessor in the current class to the associated
collection C<$collection_class>, which refers to the current class by
C<$key_in_model> in the model class of C<$collection_class>.

=cut

sub register_collection_reference {
    my ( $class, $accessor, $collection_class, @args ) = @_;
    my %args = validate( @args, { by => 1 } );
    no strict 'refs';

    Prophet::App->require( $collection_class->record_class );

    *{ $class . "::$accessor" } = sub {
        my $self       = shift;
        my $collection = $collection_class->new(
            app_handle => $self->app_handle,
        );
        $collection->matching( sub { ($_[0]->prop( $args{by} )||'') eq $self->uuid }
        );
        return $collection;
    };

    # XXX: add validater for $args{by} in $model->record_class

    $class->REFERENCES->{$class}{$accessor} = {
        %args,
        arity => 'collection',
        type  => $collection_class->record_class,
    };
}

=head2 register_record_reference $accessor, $record_class, by => $key_in_model

Registers and creates an accessor in the current class to the associated
record C<$record_class>, which refers to the current class by
C<$key_in_model> in the model class of C<$collection_class>.

=cut

sub register_record_reference {
    my ( $class, $accessor, $record_class, @args ) = @_;
    my %args = validate( @args, { by => 1 } );
    no strict 'refs';

    Prophet::App->require( $record_class );

    *{ $class . "::$accessor" } = sub {
        my $self       = shift;
        my $record = $record_class->new(
            app_handle => $self->app_handle,
            handle     => $self->handle,
        );
        $record->load(uuid => $self->prop($args{by}));
        return $record;
    };

    # XXX: add validater for $args{by} in $model->record_class

    $class->REFERENCES->{$class}{$accessor} = {
        %args,
        arity => 'scalar',
        type  => $record_class,
    };
}

=head2 create { props => { %hash_of_kv_pairs } }

Creates a new Prophet database record in your database. Sets the record's properties to the keys and values passed in.

Automatically canonicalizes and then validates the props.

Upon successful creation, returns the new record's C.
In case of failure, returns undef.

=cut

sub create {
    my $self = shift;
    my %args = validate( @_, { props => 1 } );
    my $uuid = $self->handle->uuid_generator->create_str;

    my $props = $args{props};

    $self->default_props($props);
    $self->canonicalize_props($props);

    # XXX TODO - this should be a real exception
    return undef unless (keys %$props);

    $self->validate_props($props) or return undef;
    $self->_create_record(props => $props, uuid => $uuid);
}




# _create_record is a helper routine, used both by create and by databasesetting::create
sub _create_record {
    my $self = shift;
    my %args = validate( @_, { props => 1, uuid => 1 } );

    $self->uuid($args{uuid});

    $self->handle->create_record(
        props => $args{'props'},
        uuid  => $self->uuid,
        type  => $self->type
    );

    return $self->uuid;

}

=head2 load { uuid => $UUID } or { luid => $UUID }

Given a UUID or LUID, look up the LUID or UUID (the opposite of what was
given) in the database. Set this record's LUID and UUID attributes, and return
the LUID or UUID (whichever wasn't given in the method call).

Returns undef if the record doesn't exist in the database.

=cut

sub load {
    my $self = shift;

    my %args = validate(
        @_,
        {   uuid => {
                optional  => 1,
                callbacks => {
                    'uuid or luid present' => sub { $_[0] || $_[1]->{luid} },
                },
            },
            luid => {
                optional  => 1,
                callbacks => {
                    'luid or uuid present' => sub { $_[0] || $_[1]->{uuid} },
                },
            },
        }
    );

    if ( $args{luid} ) {
        $self->luid( $args{luid} );
        $self->uuid( $self->handle->find_uuid_by_luid( luid => $args{luid} ) );
        return($self->uuid) if ($self->uuid);
    } else {
        $self->uuid( $args{uuid} );
        $self->luid( $self->handle->find_or_create_luid( uuid => $args{uuid}));
        return($self->luid) if ($self->luid);
    }

    return undef;
}

# a private method to let collection search results instantiate records more quickly
# (See Prophet::Replica::sqlite)
sub _instantiate_from_hash {
    my $self = shift;
    my %args = ( uuid => undef, luid => undef, @_);
    # we might not have a luid cheaply (see the prophet filesys backend)
    $self->luid($args{'luid'}) if (defined $args{'luid'});
    # We _Always_ have a luid
    $self->uuid($args{'uuid'});
    # XXX TODO - expect props as well
}

sub loaded {
    my $self = shift;
    return $self->uuid ? 1 : 0;
}

=head2 set_prop { name => $name, value => $value }

Updates the current record to set an individual property called C<$name> to C<$value>

This is a convenience method around L.

=cut

sub set_prop {
    my $self = shift;

    my %args = validate( @_, { name => 1, value => 1 } );
    my $props = { $args{'name'} => $args{'value'} };
    $self->set_props( props => $props );
}

=head2 set_props { props => { key1 => val1, key2 => val2} }

Updates the current record to set all the keys contained in the C parameter to their associated values.
Automatically canonicalizes and validates the props in question.

In case of failure, returns false.

On success, returns true.

=cut

sub set_props {
    my $self = shift;
    my %args = validate( @_, { props => 1 } );

    confess "set_props called on a record that hasn't been loaded or created yet." if !$self->uuid;

    $self->canonicalize_props( $args{'props'} );
    $self->validate_props( $args{'props'} ) || return undef;

    return 0 unless grep { defined } values %{$args{props}};

    $self->handle->set_record_props(
        type  => $self->type,
        uuid  => $self->uuid,
        props => $args{'props'}
    );
    return 1;
}

=head2 get_props

Returns a hash of this record's properties as currently set in the database.

=cut

sub get_props {
    my $self = shift;

    confess "get_props called on a record that hasn't been loaded or created yet." if !$self->uuid;

    return $self->handle->get_record_props(
        uuid => $self->uuid,
        type => $self->type) || {};

}

=head2 prop $name

Returns the current value of the property C<$name> for this record.
(This is a convenience method wrapped around L).

=cut

sub prop {
    my $self = shift;
    my $prop = shift;
    return $self->get_props->{$prop};
}

=head2 delete_prop { name => $name }

Deletes the current value for the property $name.
(This is currently equivalent to setting the prop to ''.)

=cut

sub delete_prop {
    my $self = shift;
    my %args = validate( @_, { name => 1 } );

    confess "delete_prop called on a record that hasn't been loaded or created yet." if !$self->uuid;

    $self->set_prop(name => $args{'name'}, value => '');

#    $self->handle->delete_record_prop(
#        uuid => $self->uuid,
#        name => $args{'name'}
#    );
}

=head2 delete

Deletes this record from the database. (Note that it does _not_ purge historical versions of the record)

=cut

sub delete {
    my $self = shift;
    delete $self->{props};
    $self->handle->delete_record( type => $self->type, uuid => $self->uuid );

}

=head2 changesets { limit => $int }

Returns an ordered list of changeset objects for all changesets containing
changes to the record specified by this record object.

Note that changesets may include changes to other records.

If a limit is specified, this routine will only return that many
changesets, starting from the changeset containing the record's
creation.

=cut

sub changesets {
    my $self = shift;
    my %args = validate(@_, { limit => 0});
    return $self->handle->changesets_for_record(
        uuid => $self->uuid,
        type => $self->type,
        $args{limit} ? (limit => $args{limit}) : ()
    );
}

=head2 changes

Returns an ordered list of all the change objects that represent changes
to the record specified by this record object.

=cut

sub changes {
    my $self = shift;
    my $uuid = $self->uuid;
    my @changesets = $self->changesets;

    return grep { $_->record_uuid eq $uuid }
            map { $_->changes }
            @changesets;
}

=head2 uniq @list

The C function (taken from version 0.21).

Returns a new list by stripping duplicate values in @list. The order of
elements in the returned list is the same as in @list. In scalar
context, returns the number of unique elements in @list.

    my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4
    my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5

=cut

sub uniq (@) { my %h; map { $h{$_}++ == 0 ? $_ : () } @_; }

=head2 validate_props $propsref

Takes a reference to a props hash and validates each prop in the
hash or in the C attribute that has a validation routine
(C).

Dies if any prop fails validation. Returns true on success. Returns
false if any prop is not allowable (prop name fails validation).

=cut

sub validate_props {
    my $self   = shift;
    my $props  = shift;
    my $errors = {};
    my @errors;
    for my $key ( uniq( keys %$props, $self->declared_props ) ) {
        return undef unless ( $self->_validate_prop_name($key) );
        if ( my $sub = $self->can( 'validate_prop_' . $key ) ) {
            $sub->( $self, props => $props, errors => $errors ) ||
                push @errors,"Validation error for '$key': " .
                    ( $errors->{$key} || '' ) . '.';
        }
    }
    if (@errors) {
        die join( "\n", @errors )."\n";
    }
    return 1;
}

=head2 _validate_prop_name

A hook to allow forcing users to only use certain prop names.

Currently just returns true for all inputs.

=cut

sub _validate_prop_name {1}

=head2 canonicalize_props $propsref

Takes a hashref to a props hash and canonicalizes each one if a
C routine is available.

Returns true on completion.

=cut

sub canonicalize_props {
    my $self   = shift;
    my $props  = shift;
    my $errors = {};
    for my $key ( uniq( keys %$props, $self->declared_props ) ) {
        $self->canonicalize_prop($key, $props, $errors);
    }
    return 1;
}

sub canonicalize_prop {
    my $self = shift;
    my $prop = shift;
    my $props = shift;
    my $errors = shift;
        if ( my $sub = $self->can( 'canonicalize_prop_' . $prop ) ) {
            $sub->( $self, props => $props, errors => $errors );
            return 1;
        }


    return 0;
}


=head2 default_props $props_ref

Takes a reference to a hash of props and looks up the defaults for those
props, if they exist (by way of C routines). Sets the
values of the props in the hash to the defaults.

=cut

sub default_props {
    my $self   = shift;
    my $props  = shift;

    my @methods = grep { /^default_prop_/ } $self->meta->get_all_method_names;

    for my $method (@methods) {
        my ($key) = $method =~ /^default_prop_(.+)$/;

        $props->{$key} = $self->$method(props => $props)
            if !defined($props->{$key});
    }

    return 1;
}

=head2 default_prop_creator

Default the creator of every record to the changeset_creator (usually the current user's email address.)

=cut

sub default_prop_creator {
    my $self = shift;
    return $self->handle->changeset_creator;
}

=head2 default_prop_original_replica

Default the original_replica of every record to the replica's uuid.

=cut

sub default_prop_original_replica {
    my $self = shift;
    return $self->handle->uuid;
}

=head2 validate_prop_from_recommended_values 'prop', $argsref

Checks to see if the given property has a valid value and returns true if so.
If not, adds an error message to $argsref->{errors}{prop} and returns false.

=cut

sub validate_prop_from_recommended_values {
    my $self = shift;
    my $prop = shift;
    my $args = shift;

    if ( my @options = $self->recommended_values_for_prop($prop) ) {
        return 1 if ((scalar grep { $args->{props}{$prop} eq $_ } @options)
            # force-set props with ! to bypass validation
            || $args->{props}{$prop} =~ s/!$//);

        $args->{errors}{$prop}
            = "'" . $args->{props}->{$prop} . "' is not a valid $prop";
        return 0;
    }
    return 1;

}

=head2 recommended_values_for_prop 'prop'

Given a record property, return an array of the values that should usually be
associated with this property.

If a property doesn't have a specific range of values, undef is
returned.

This is mainly intended for use in prop validation (see
L). Recommended values for a
prop are set by defining methods called C<_recommended_values_for_prop_$prop>
in application modules that inherit from L.

=cut

sub recommended_values_for_prop {
    my $self = shift;
    my $prop = shift;

    if (my $code = $self->can("_recommended_values_for_prop_".$prop)) {
        $code->($self, @_);
    } else {
        return undef;
    }

}

=head2 _default_summary_format

A string of the default summary format for record types that do not
define their own summary format.

A summary format should consist of format_string,field pairs, separated
by | characters.

Fields that are not property names must start with the C<$> character and be
handled in the C routine.

Example:

C<'%s,$luid | %s,summary | %s,status'>

=cut

sub _default_summary_format {  undef }

=head2 _summary_format

Tries to find the summary format for the record type. Returns
L<_default_summary_format> if nothing better can be found.

=cut

sub _summary_format {
    my $self = shift;
    return
        $self->app_handle->config->get( key => $self->type.'.summary-format' )
        || $self->app_handle->config->get( key => 'record.summary-format' )
        || $self->_default_summary_format;
}

=head2 _atomize_summary_format [$format]

Splits a summary format into pieces (separated by arbitrary whitespace and
the | character). Returns the split list.

If no summary format is supplied, this routine attempts to find one by
calling L<_summary_format>.

=cut

sub _atomize_summary_format {
    my $self = shift;
    my $format = shift || $self->_summary_format;

    return undef unless $format;
    return split /\s*\|\s*/, $format;
}

=head2 _parse_format_summary

Parses the summary format for this record's type (or the default summary
format if no type-specific format exists).

Returns a list of hashrefs to hashes which contain the following keys:
C, C, C, and C

(These are the format string, the property to be formatted, the value
of that property, and the atom formatted according to C,
respectively.)

If no format string is supplied in a given format atom, C<%s> is used.

If a format atom C<$value>'s value does not start with a C<$> character, it is
swapped with the value of the prop C<$value> (or the string "(no value)".

All values are filtered through the function C.

=cut

sub _parse_format_summary {
    my $self   = shift;

    my $props = $self->get_props;

    my @out;
    for my $atom ($self->_atomize_summary_format) {
        my %atom_data;
        my ($format, $prop, $value);

        if ($atom =~ /,/) {
            ($format, $prop) = split /,/, $atom;

            $value = $prop;

            unless ($value =~ /^\$/) {
                $value = $props->{$value}
                      || "-"
            }

        } else {
            $format = '%s';
            $prop = $value = $atom;
        }

        my $atom_value = $self->atom_value($value);
        push @out, {
            format    => $format,
            prop      => $prop,
            value     => $atom_value,
            formatted => $self->format_atom( $format => $atom_value )

        };
    }
    return @out;
}

=head2 format_summary

Returns a formatted string that is the summary for the record. In an
array context, returns a list of

=cut

sub format_summary {
    my $self = shift;

    my @out = $self->_summary_format ?
    $self->_parse_format_summary
    :
    $self->_format_all_props_raw
    ;
    return @out if wantarray;
    return join ' ', map { $_->{formatted} } @out;
}

sub _format_all_props_raw {
    my $self  = shift;
    my $props = $self->get_props;

    my @out;

    push @out,
        {
        prop      => 'uuid',
        value     => $self->uuid,
        format    => '%s',
        formatted => "'uuid': '" . $self->uuid . "'"
        };
    push @out, {
        prop      => 'luid',
        value     => $self->luid,
        format    => '%s',
        formatted => "'luid': '"
            . $self->luid . "'"

    };

    for my $prop ( keys %$props ) {
        push @out,
            {
            prop      => $prop,
            value     => $props->{$prop},
            format    => '%s',
            formatted => "'$prop': '" . $props->{$prop} . "'"
            };
    }
    return @out;
}


=head2 atom_value $value_in

Takes an input value from a summary format atom and returns either its
output value or itself (because it is a property and its value should be
retrieved from the props attribute instead).

For example, an input value of "$uuid" would return the record object's
C field.

=cut

sub atom_value {
    my $self     = shift;
    my $value_in = shift || '';

    if ($value_in =~ /^\$[gu]uid/) {
        return $self->uuid;
    } elsif ($value_in eq '$luid') {
        return $self->luid;
    }

    return $value_in;
}

=head2 format_atom $string => $value

Takes a format string / value pair and returns a formatted string for printing.

=cut

sub format_atom {
    my $self = shift;
    my $string = shift;
    my $value = shift;
    return sprintf($string, $self->atom_value($value));
}

=head2 find_or_create_luid

Finds the luid for the records uuid, or creates a new one. Returns the luid.

=cut

sub find_or_create_luid {
    my $self = shift;
    my $luid = $self->handle->find_or_create_luid( uuid => $self->uuid );
    $self->luid($luid);
    return $luid;
}

=head2 history_as_string

Returns this record's changesets as a single string.

=cut

sub history_as_string {
    my $self = shift;
    my $out ='';
    for my $changeset ($self->changesets) {
        $out .= $changeset->as_string(change_filter => sub {
            shift->record_uuid eq $self->uuid
        });
    }

    return $out;
}

=head2 record_reference_methods

Returns a list of method names that refer to other individual records

=cut

sub record_reference_methods {
    my $self = shift;
    my $class = blessed($self) || $self;
    my %accessors = %{ $self->REFERENCES->{$class} || {} };

    return grep { $accessors{$_}{arity} eq 'record' }
           keys %accessors;
}

=head2 collection_reference_methods

Returns a list of method names that refer to collections

=cut

sub collection_reference_methods {
    my $self = shift;
    my $class = blessed($self) || $self;
    my %accessors = %{ $self->REFERENCES->{$class} || {} };

    return grep { $accessors{$_}{arity} eq 'collection' }
           keys %accessors;
}

__PACKAGE__->meta->make_immutable;
no Any::Moose;
1;