source: branches/4.0/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Attributes.pm @ 1299

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}) {
        return $self->{input}->($value);
    } else {
        return $value;
    }
}

=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($attr)

Return the value for this attribute

=cut

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

    if (ref $self->{get} eq 'CODE') {
        return $self->{get}->($self);
    } else {
        return $self->object->get_field($self->iname);
    }
}

=head2 set ($values)

Set attribute value to attached object

=cut

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

    if (ref $self->{set} eq 'CODE') {
        return $self->{set}->($self,
            ref $values
            ? [ map { $self->input($_) } @$values ]
            : $values ? $self->input($values) : undef);
    } else {
        return $self->object->set_fields(
            $self->iname,
            ref $values
                ? [ map { $self->input($_) } @$values ]
                : $values ? $self->input($values) : undef);
    }
}

=head2 default_value

Return default value for this attribute

=cut

sub default_value {
    my ($self) = @_;
    return grep { $_ } (ref $self->{default}
        ? @{ $self->{default} }
        : $self->{default});
}

=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