source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Attributes.pm @ 1567

package LATMOS::Accounts::Bases::Attributes;

# $Id$

use strict;
use warnings;
use LATMOS::Accounts::Log;

=head1 NAME

    LATMOS::Accounts::Bases::Attributes - Object to handle attribute schema

=head1 FUNCTIONS

=head2 new($attributes, $base_or_object, $maybe_otype)

Instanciate a new Attributes object.

=cut

sub new {
    my ($class, $attributes, $base_or_object, $maybe_otype) = @_;
    
    my ($object, $base, $otype) =
    $base_or_object->isa('LATMOS::Accounts::Bases::Objects')
        ? ($base_or_object, $base_or_object->base, $base_or_object->type)
        : (undef, $base_or_object, $maybe_otype);

    if (ref $attributes) {
        $attributes->{_base} = $base;
        $attributes->{_object} = $object;
        $attributes->{_name} = $attributes->{name};
        $attributes->{_otype} = $otype;
        return bless($attributes, $class);
    } else {
        my $attr_info = $base->get_attr_schema($otype, $attributes) or return;

        $attr_info->{_base} = $base;
        $attr_info->{_object} = $object;
        $attr_info->{_name} = $attributes;
        $attr_info->{_otype} = $otype;

        return bless($attr_info, $class);
    }
}

=head2 base

Return base handle

=cut

sub base  { $_[0]->{_base}  }

=head2 name

Return attribute name

=cut

sub name  { $_[0]->{_name}  }

=head2 otype

Return object type for this attribute

=cut


sub otype { $_[0]->{_otype} }

=head2 mandatory

Return true if attribute is mandatory

=cut

sub mandatory { $_[0]->{mandatory} || 0 }

=head2 object

Return handle object if any

=cut

sub object { $_[0]->{_object} }

=head2 reference

A object type this attribute refer to

=cut

sub reference {
    my ($self) = @_;
    if ($self->{reference} &&
        $self->base->is_supported_object($self->{reference})) {
        return $self->{reference};
    } else {
        return;
    }
}

=head2 iname

Return internal name of attributes

=cut

sub iname { $_[0]->{iname} || $_[0]->name }

=head2 label

Return the label to display

=cut

sub label { $_[0]->{label} || $_[0]->{_name} }

=head2 has_values_list

Return true if the attribute have a fixed list of accepted values

=cut

sub has_values_list {
    my ($self) = @_;
    if ($self->base->obj_attr_allowed_values(
        $self->otype,
        $self->name) ||
        $self->{can_values} ||
        $self->reference) {
        return 1;
    } else {
        return 0;
    }
}

=head2 can_values

Return possible value allowed by this attribute

=cut

sub can_values {
    my ($self) = @_;
    if (my @values = $self->base->obj_attr_allowed_values(
            $self->otype,
            $self->name)) {
        return @values;
    } elsif ($self->{can_values}) {
        if (ref $self->{can_values} eq 'ARRAY') {
            return @{$self->{can_values}};
        } elsif (ref $self->{can_values} eq 'CODE') {
            $self->{can_values}->($self, $self->object);
        } else {
            return;
        }
    } elsif (my $ref = $self->reference) {
        return $self->base->list_objects($ref);
    } else { return }
}

=head2 display ($value)

Return the well formated value according attribute

=cut

sub display {
    my ($self, $value) = @_;
    if ($self->{display}) {
        return $self->{display}->($self, $value);
    } else {
        return $value;
    }
}

=head2 input ($value)

Return well formated single value for insert into base

=cut

sub input {
    my ($self, $value) = @_;
    if ($self->{input}) {
        if (!defined($value)) { return }
        return $self->{input}->($value);
    } else {
        return $value;
    }
}

=head2 checkinputformat ($value)

Check input value format, return false on error

=cut

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

    if ($self->{checkinputformat}) {
        if (!$self->{checkinputformat}->($value)) {
           return;
        }
    }

    return 1;
}

=head2 checkinput ($value)

Check input value, return false on error

=cut

sub checkinput {
    my ($self, $values) = @_;

    foreach my $value (ref $values ? @{ $values } : $values) {
        if (!$self->checkinputformat($value)) {
            $self->base->log(LA_ERR, "Wrong format for  %s/%s: %s",
               $self->name,
               $self->{_otype},
               $value
            );
            return;
        }
    }

    if ($self->mandatory &&
        (!(defined($values)) || $values eq '')) {
        $self->base->log(LA_ERR,
            "%s attribute cannot be empty for object %s",
            $self->name,
            $self->{_otype},
        );
        return;
    }

    if ($self->has_values_list && $values) {
        my @possible = $self->can_values;
        foreach my $value (ref $values ? @{ $values } : $values) {
            if (! grep { $value eq $_ } @possible) {
                $self->base->log(LA_ERR,
                    "%s attribute cannot have `%s' as value for object %s/%s",
                    $self->name,
                    $value,
                    $self->object->type,
                    $self->object->id,
                ) if ($self->object);
                $self->base->log(LA_DEBUG, "Possible value for %s: %s",
                    $self->name,
                    join(', ', @possible)
                );
                return;
            }
        }
    }

    if (ref $values eq 'ARRAY' && ! $self->multiple) {
        $self->base->log(LA_WARN, 'Attribute %s is not multi valuesd', $self->name);
        # TODO: really return an error
        # return;
    }

    if ($self->{checkinput}) {
        foreach my $val (ref $values ? @{ $values } : $values) {
            if (!$self->{checkinput}->($val)) {
                return;
            }
        }
    }

    return 1;
}

=head2 readable

Return true if attribute can be read

=cut

sub readable {
    my ($self) = @_;
    if (ref $self->{readable} eq 'CODE') {
        return $self->{readable}->($self->object) || 0;
    } else {
        return defined($_[0]->{readable}) ? $_[0]->{readable} : 1;
    }
}

=head2 ro

Return true if the attribute cannot be write by design

=cut

sub ro {
    my ($self) = @_;
    if (ref $self->{ro} eq 'CODE') {
        return $self->{ro}->($self->object) || 0;
    } else {
        return $_[0]->{ro} || 0 
    }
}

=head2 readonly

Return true if attribute cannot be read according acls or attributes state

=cut

sub readonly { 
    my ($self) = @_;
    return 1 if ($self->ro);
    
    return ! $self->check_acl('w');
}

=head2 check_acl ($mode)

Return true is access to C<$mode> is granted

=cut

sub check_acl {
    my ($self, $mode) = @_;

    return 1 if ($self->{_noacl});

    return $self->base->check_acl($self->object
        ? ($self->object, $self->name, $mode)
        : ($self->otype, '@CREATE', $mode));
}

=head2 real_form_type

Return the way the fields must be show in GUI.
For each type option maybe given by form_option

=head3 LABEL

=over 4

=item length

The length to use to show the attribute

=back

=head3 TEXT

=head3 TEXTAREA

=head3 DATE

=head3 LIST

=head3 CHECKBOX

=over 4

=item rawvalue

The real value of the attribute must be show

=back

=cut

sub real_form_type { $_[0]->{formtype} || 'TEXT' }

=head2 form_type

Return the way the attribute must be displayed

=cut

sub form_type {
    $_[0]->readonly ? 'LABEL' :
    $_[0]->{formtype} ? $_[0]->{formtype} :
    $_[0]->has_values_list ? 'LIST' :
    $_[0]->real_form_type
}

=head2 form_option ($option)

Return the form option C<$option>

=cut

sub form_option {
    my ($self, $option) = @_;
    return $self->{formopts}{$option}
}

=head2 uniq

Return true is attribute value must be uniq

=cut

sub uniq { $_[0]->{uniq} || 0 }

=head2 multiple

Return true is attribute value can be set several times

=cut

sub multiple { $_[0]->{multiple} || 0 }

=head2 hidden

Return true if attributes must not appear in list by can be query.

=cut

sub hidden { $_[0]->{hide} || 0 }

=head2 delayed

Return true if attribute must be set after object creation during
synchronisation

=cut

sub delayed { $_[0]->{delayed} || 0 }

=head2 get

Return the value for this attribute

=cut

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

    if (defined($self->object)) {
        my $res = (ref($self->{get}) eq 'CODE')
            ? $self->{get}->($self)
            : $self->object->get_field($self->iname);

        # always return undef if empty
        # and an array if attribute is multivalued
        if (!$res) {
            return undef;
        } elsif (ref $res) {
            return @{$res} ? $res : undef;
        } elsif ($self->multiple) {
            return (ref $res ? $res : [$res])
        } else {
            return $res;
        }
    } else {
        return;
    }
}

=head2 defaultValue

Return the default static value for this attribute.

=cut

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

    return $self->base->defaultAttributeValue($self->otype, $self->name)
}

=head2 getValues

Return value for this attribute, results are always return as an array

=cut

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

    my $res = $self->get();

    return ref $res ? grep { $_ } @{ $res } : $res;
}


=head2 set ($values)

Set attribute value to attached object

=cut

sub set {
    my ($self, $values) = @_;

    my $inputv = ref $values
        ? [ map { $self->input($_) } @$values ]
        : $values ? $self->input($values) : undef;

    my $res = ref $self->{set} eq 'CODE'
        ? $self->{set}->($self, $inputv)
        : $self->object->set_fields($self->iname, $inputv);

    # If the attribute has a post code, call it
    if ($res && $self->{post}) {
        $self->{post}->($self, $inputv);
    }

    $res
}

=head2 default_value

Return default value for this attribute

=cut

sub default_value {
    my ($self) = @_;
    $self->defaultValue;
}

=head2 monitored

Return true if the attribute is monitored

=cut

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

    if ($self->iname ne $self->name) {
        my $attr = $self->base->attribute($self->otype, $self->iname) or return;
        return $attr->monitored;
    } else {
        return $self->{monitored} || 0;
    }
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Bases>

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2012 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut