source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/Accreq.pm @ 984

package LATMOS::Accounts::Bases::Sql::Accreq;

use 5.010000;
use strict;
use warnings;

use LATMOS::Accounts::Utils;
use LATMOS::Accounts::Log;
use base qw(LATMOS::Accounts::Bases::Sql::objects);
use YAML;

our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Accounts::Bases::Sql::Accreq - Accreq object in LATMOS::Accounts system

=head1 DESCRIPTION

The C<Accreq> object is a form handle information about form allowing user to
request admin for change

=head1 FUNCTIONS

=cut

sub _yaml_attr { qw(description notifyMail) }

sub object_table { 'accreq' }

sub key_field { 'name' }

sub has_extended_attributes { 1 }

sub _get_attr_schema {
    my ($class, $base) = @_;

    $class->SUPER::_get_attr_schema($base,
        {
            unexported  => { inline => 1, formtype => 'CHECKBOX',},
            name        => { inline => 1, ro => 1, },
            create      => { inline => 1, ro => 1, },
            date        => { inline => 1, ro => 1, },
            attributes  => {
                ro => 1,
                multiple => 1,
                get => sub {
                    my ($self) = @_;
                    my $ref = _parse_form($self,
                        $self->object->get_attributes('form'));
                    my @attributes = ();
                    my @attrs = @{ $ref->{attrs} };
                    while (my $attr = shift(@attrs)) {
                        my $attrname = ref $attr
                        ? $attr->{name}
                        : $attr;
                        push(@attributes, $attrname);
                    }
                    \@attributes
                },
            },
            oType       => {
                can_values => sub {
                    return $base->list_supported_objects
                },
                mandatory => 1,
            },
            requireObject => { formtype => 'CHECKBOX', },
            form => {
                get => sub {
                    my ($self) = @_;
                    if (my $obj = $self->object) {
                        my $res = $obj->parse_form;
                        foreach (_yaml_attr()) {
                            $res->{$_} = $obj->get_field($_);
                        }
                        return YAML::freeze($res);
                    } else {
                        return;
                    }
                },
                set => sub {
                    my ($self, $yaml) = @_;
                    my $res = _parse_form($self, $yaml)
                        or return 0;
                    my %attrs;
                    foreach (_yaml_attr()) {
                        $attrs{$_} = $res->{$_} if (exists($res->{$_}));
                    }
                    $self->object->set_fields(%attrs, form => $yaml);
                },
            },
        }
    )
}

sub parse_form {
    my ($self) = @_;
    if (my $text = $self->get_field('form')) {
        $self->_parse_form($text);
    } else {
        return { attrs => [] };
    }
}

sub attr_info {
    my ($self, $wanted_attr) = @_;

    my $ref = $self->parse_form;

    my @attrs = @{ $ref->{attrs} };
    while (my $attr = shift(@attrs)) {
        my $attrname = ref $attr
            ? $attr->{name}
            : $attr;
        if ($wanted_attr eq $attrname) {
            if (ref $attr) {
                return $attr;
            } else {
                return;
            }
        }
    }
    return;
}

sub _parse_form {
    my ($self, $yaml) = @_;

    my $ref = YAML::thaw($yaml) or return 0;

    my @attributes = ();
    my @attrs = @{ $ref->{attrs} };
    while (my $attr = shift(@attrs)) {
        my $attrname = ref $attr
            ? $attr->{name}
            : $attr;

        if (!$attrname) {
            $self->base->log('LA_ERR', 'No attribute name supplied');
            return;
        }
    }

    $ref
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 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