package LATMOS::Accounts::Bases::Sql::objects;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases::Objects);
use LATMOS::Accounts::Log;
use Crypt::RSA;
use Crypt::RSA::Key::Public::SSH;
use DateTime;
use LATMOS::Accounts::I18N;

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

=head1 NAME

LATMOS::Accounts::Bases::Sql::objects - Parent class for SQL object

=cut

sub _attributes_table { $_[0]->_object_table . '_attributes_list' }

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

    my $sth = $base->db->prepare_cached(
        sprintf(
            q{select %s as k from %s where internobject = false
                and oalias IS NULL %s order by %s},
            $base->db->quote_identifier($class->_key_field),
            $base->db->quote_identifier($class->_object_table),
            ($base->{wexported} ? '' : 'and exported = true'),
            $base->db->quote_identifier($class->_key_field),
        )
    );
    $sth->execute;
    my @keys;
    while(my $res = $sth->fetchrow_hashref) {
        push(@keys, $res->{k});
    }
    @keys
}

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

    my $sth = $base->db->prepare_cached(
        sprintf(
            q{select %s as k from %s where internobject = false %s order by %s},
            $base->db->quote_identifier($class->_key_field),
            $base->db->quote_identifier($class->_object_table),
            ($base->{wexported} ? '' : 'and exported = true'),
            $base->db->quote_identifier($class->_key_field),
        )
    );
    $sth->execute;
    my @keys;
    while(my $res = $sth->fetchrow_hashref) {
        push(@keys, $res->{k});
    }
    @keys
}

sub list_from_rev {
    my ($class, $base, $rev) = @_;
    my $sth = $base->db->prepare_cached(
        sprintf(
            q{select %s as k from %s where rev > ? and internobject = false
                and oalias IS NULL  %s order by %s},
            $base->db->quote_identifier($class->_key_field),
            $base->db->quote_identifier($class->_object_table),
            ($base->{wexported} ? '' : 'and exported = true'),
            $base->db->quote_identifier($class->_key_field),
        )
    );
    $sth->execute($rev);
    my @keys;
    while(my $res = $sth->fetchrow_hashref) {
        push(@keys, $res->{k});
    }
    @keys
}

sub _has_extended_attributes { 0 }

sub _get_attr_schema {
    my ($class, $base, $info) = @_;
    $info ||= {};
    if (!$base->{__cache}{$class->_object_table}{inline}) {
        $base->{__cache}{$class->_object_table}{inline} = [];
        my $sth = $base->db->prepare(
            q{SELECT column_name FROM information_schema.columns
              WHERE table_name = ?}
        );
        $sth->execute($class->_object_table);
        while (my $res = $sth->fetchrow_hashref) {
            push(@{$base->{__cache}{$class->_object_table}{inline}},
                $res->{column_name});
        }
    }
    foreach (@{$base->{__cache}{$class->_object_table}{inline}}) {
        $info->{$_}{inline} = 1;
        if (m/^(rev|date|create|ikey)$/) {
            $info->{$_}{ro} = 1
        }
    }

    # Common to all object attribute:
    my %commons = (
        name      => {
            inline => 1,
            ro => 1,
            label => l('Name'),
        },
        create    => {
            inline => 1,
            ro => 1,
            label => l('Created'),
        },
        date      => {
            inline => 1,
            ro => 1,
            label => l('Last modified'),
        },
        exported   =>   { inline => 1, formtype => 'CHECKBOX', hide => 1, monitored => 1 },
        unexported =>   {
            inline => 1,
            managed => 1,
            formtype => 'CHECKBOX',
            get => sub {
                my ($self) = @_;
                return $self->object->get_field('exported') ? undef : 1;
            },
            set => sub {
                my ($self, $data) = @_;
                $self->object->_set_c_fields('exported', $data ? 0 : 1);
            },
            label => l('Hidden'),
        },
        services   =>   {
            managed => 1,
            multiple => 1,
            reference => 'service',
            label => l('Service'),
        },
        modifiedby =>   {
            inline  => 1,
            reference => 'user',
            ro => 1,
            label => l('Modified by'),
        },
        createdby => {
            inline  => 1,
            reference => 'user',
            ro => 1,
            label => l('Created by'),
        },
        oalias => {
            inline  => 1,
            reference => $class->type,
            label => 'Alias for',
            post => sub {
                my ($self, $value) = @_;
                $self->object->_update_aliases_ptr();
                $self->object->_update_aliases_cache();
            },
            checkinput => sub {
                my ($oalias) = @_;
                my $otype = $class->type;
                $oalias ||= '';

                if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) {
                    my $attribute = $base->attribute($aliasotype, $aliasattr) or do {
                        $base->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s",
                            $otype, $oalias, $aliasotype, $aliasattr);
                        return;
                    };
                    my $refotype = $attribute->reference or do {
                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object",
                            $otype, $oalias);
                        return;
                    };

                    if ($attribute->multiple) {
                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute must not be multiple",
                            $otype, $oalias);
                        return;
                    };
                } elsif(!$base->get_object($otype, $oalias)) {
                    $base->log(LA_DEBUG, "Cannot get object $otype/$oalias");
                    return;
                }
                return 1;
            },
        },
        oaliascache => {
            inline  => 1,
            reference => $class->type,
            label => 'Cache for oalias data',
            hide => 1,
        },
        internobject => {
            inline  => 1,
            label => 'True if object is for internal use',
            hide => 1,
        },
        nodelete => {
            inline => 1,
            label => 'True if the object is protected against deletion',
            hide => 1,
        },
    );

    # Merging / overriding with common to all object attributes properties
    foreach my $attr (keys %commons) {
        foreach my $var (keys %{ $commons{$attr} }) {
            $info->{$attr}{$var} = $commons{$attr}{$var};
        }
    }

    # TODO kill this code: useless since everything is declared in perl code
    if ($class->_has_extended_attributes) {
        if (!$base->{__cache}{$class->_object_table}{extend}) {
            $base->{__cache}{$class->_object_table}{extend} = [];
            my $sth = $base->db->prepare_cached(
                sprintf(
                    q{select canonical from %s order by canonical},
                    $base->db->quote_identifier($class->_attributes_table),
                )
            );
            $sth->execute;
            while (my $res = $sth->fetchrow_hashref) {
                push(@{$base->{__cache}{$class->_object_table}{extend}},
                        $res->{canonical});
            }
        }
        foreach (@{$base->{__cache}{$class->_object_table}{extend}}) {
            #$base->log(LA_DEBUG, 'Attribute %s for %s not declared in code', $_, $class->type) if(!exists($info->{$_}));
            $info->{$_} ||= {};
        }
    }

    $info
}

# Everything managed by the perl code

sub _managed_fields {
    my ($class, $for, $base) = @_;
    return();
}

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

    my $__cache = $base->{__cache}{"_" . $class->type};

    if (!(exists($__cache->{$id})
        && $__cache->{$id}{__time} >= time - 1)) {

        my $sth = $base->db->prepare_cached(
            sprintf(q{ select 1 from %s where %s = ? %s},
                $base->db->quote_identifier($class->_object_table),
                $base->db->quote_identifier($class->_key_field),
                ($base->{wexported} ? '' : 'and exported = true'),
            ),
        );
        my $count = $sth->execute($id);
        $sth->finish;
        ($count || 0) == 1 or return;
    }
    $class->SUPER::new($base, $id);
}

sub Iid { $_[0]->_get_ikey }

sub _get_ikey {
    my ($class, $base, $id) = @_;
    $base ||= $class->base;
    $id ||= $class->id;
    my $sth = $base->db->prepare_cached(
        sprintf(
            q{select ikey from %s where %s = ?},
            $base->db->quote_identifier($class->_object_table),
            $base->db->quote_identifier($class->_key_field),
        )
    );
    $sth->execute($id);
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    $res->{ikey}
}

sub _create {
    my ($class, $base, $id, %data) = @_;

    # splitting inline from extended
    my (%first, %second);
    # Ensure object is exported if not specified
    $data{exported} = 1 if (!exists($data{exported}));
    if (exists $data{unexported}) {
        $data{exported} = $data{unexported} ? 0 : 1;
        delete $data{unexported}
    }
    foreach (keys %data) {
        my $attr = $base->attribute($class->type, $_) or next;
        $_ =~ /^exported$/ and $data{$_} = $data{$_} ? 1 : 0;
        my $formatted = ref($data{$_})
            ? [ map { $attr->input($_) } @{ $data{$_} } ]
            : $attr->input($data{$_});
        if ($attr->{inline} && ! $attr->{delayed}) {
            my $iname = $attr->iname;
            $first{$iname} = $formatted;
        } else {
            # the real internal name will be translate by _set_c_field
            $second{$_} = $formatted if(defined($formatted));
        }
    }
    $first{$class->_key_field} = $id;
    $first{createdby} =  $base->user || '@Console';
    $first{modifiedby} = $base->user || '@Console';

    my $lastid;
    {
        my $sthnextval = $base->db->prepare_cached("select nextval('ikey_seq') as c");
        $sthnextval->execute;
        $lastid = $sthnextval->fetchrow_hashref()->{c};
        $first{ikey} = $lastid;
        $sthnextval->finish;
    }

    my $sth = $base->db->prepare(
        sprintf(
            q{insert into %s (%s) values (%s)},
            $base->db->quote_identifier($class->_object_table),
            join(', ', map { $base->db->quote_identifier($_) } sort keys %first),
            join(',', qw(?) x scalar(keys %first)),
        )
    );
    $sth->execute(map { defined($first{$_}) ? $first{$_} : undef } sort keys %first) or return;

    my $sthid = $base->db->prepare_cached(
        sprintf(q{select %s as k from %s where ikey = ?},
            $base->db->quote_identifier($class->_key_field),
            $base->db->quote_identifier($class->_object_table),
        )
    );
    $sthid->execute($lastid);
    my $res = $sthid->fetchrow_hashref();
    $sthid->finish;
    $res or do {
        $base->log(LA_DEBUG, 'Cannot retrieve SQL row from freshly create object %s/%s', $class->type, $id);
        return;
    };

    my $obj = $class->new($base, $res->{k}) or return;
    if (keys %second) {
        $obj->_set_c_fields(%second) or do {
            $base->log(LA_DEBUG, 'Cannot set attributes to freshly create object %s/%s', $class->type, $id);
            return;
        };
    }

    return $res->{k};
}

=head2 refreshRev

Increase revision of the object to force synchronisation

=cut

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

    my $sth = $self->db->prepare_cached(
        sprintf(q{
                UPDATE %s SET rev = nextval('revisions_rev_seq'::regclass)  WHERE %s = ?
            },
            $self->db->quote_identifier($self->_object_table),
            $self->db->quote_identifier($self->_key_field),
        )
    );
    $sth->execute($self->id);
}

=head2 CreateAlias($base, $name, $for)

Create an alias named C<$name> with pointing to C<$for>

=cut

sub CreateAlias {
    my ($class, $base, $name, $for) = @_;

    $base->log(LA_ERR, '%s does not support alias object, alias %s not created', $class->type, $name);
}

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

    my $__cache = $base->{__cache}{"_" . $class->type};

    my $obj = $base->get_object($class->type, $id)
        or return;

    if ($obj->_get_attributes('internobject')) {
        # Cannot happend: internal are not fetchable
        $base->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $class->type, $id);
        return;
    }
    if ($obj->_get_attributes('nodelete')) {
        $base->log(LA_ERR,'Cannot delete %s/%s: is write protected', $class->type, $id);
        return;
    }

    my $sthd = $base->db->prepare_cached(
        sprintf(
            q{delete from %s where %s = ?},
            $base->db->quote_identifier($class->_object_table),
            $base->db->quote_identifier($class->_key_field),
        )
    );
    my $res = $sthd->execute($id);
    if ($res) {
        delete($__cache->{$id});
    }

    $res
}

sub _rename {
    my ($class, $base, $id, $newid) = @_;

    my $sthr = $base->db->prepare_cached(
        sprintf(
            q{update %s set %s = ? where %s = ?},
            $base->db->quote_identifier($class->_object_table),
            $base->db->quote_identifier($class->_key_field),
            $base->db->quote_identifier($class->_key_field),
        )
    );

    if (($sthr->execute($newid, $id) || 0) != 1) {
        $base->log(LA_ERR, "Erreur renaming %s %s to %s",
            $class->type,
            $id, $newid,
        );
        return;
    }

    1;
}

=head2 db

Return reference to L<DBI> object.

=cut

sub db {
    return $_[0]->base->db;
}

sub _quote_object_table {
    my ($self) = @_;
    my $table = $self->_object_table or return;
    $self->db->quote_identifier($table);
}
sub _quote_key_field {
    my ($self) = @_;
    my $key_field = $self->_key_field or return;
    $self->db->quote_identifier($key_field);
}

sub get_field {
    my ($self, $field) = @_;
    if ($field eq 'services') {
        my @services;
        my $sth = $self->db->prepare_cached(
            q{ select name from service join service_attributes
               on okey = ikey
               where service_attributes.attr = 'dependOn' and value = ?
               });
        $sth->execute($self->type . '.' . $self->id);
        while(my $res = $sth->fetchrow_hashref) {
            push(@services, $res->{name});
        }
        return \@services; 
    }
    my $attr = $self->attribute($field) or return;
    if ($attr->{inline}) {
    my $sth = $self->db->prepare_cached(
        sprintf(
            q{select %s from %s where %s = ?},
            $self->db->quote_identifier(lc($field)),
            $self->_quote_object_table,
            $self->_quote_key_field,
        )
    );
    $sth->execute($self->id);
    my $res = $sth->fetchrow_hashref or $self->db->rollback;
    $sth->finish;
    return $res->{$field};
    } elsif ($self->_has_extended_attributes) { # else, then we mandatory have extend attr
        $self->base->{__cache}{"_" . $self->type} ||= {};
        my $__cache = $self->base->{__cache}{"_" . $self->type};
        if (!(exists($__cache->{$self->id})
            && $__cache->{$self->id}{__time} >= time - 1)) {
        my $sth = $self->db->prepare_cached(
            sprintf(
                q{
                select attr, value from %s 
                join %s on okey = ikey
                where %s = ?
                },
                $self->db->quote_identifier($self->_object_table. '_attributes'),
                $self->db->quote_identifier($self->_object_table),
                $self->db->quote_identifier($self->_key_field),
            )
        );
        $sth->execute($self->id);
        delete($__cache->{$self->id});
        $__cache->{$self->id}{__time} = time;
        while(my $res = $sth->fetchrow_hashref) {
            push(@{$__cache->{$self->id}{$res->{attr}}}, $res->{value});
        }
        #return @values > 1 ? \@values : $values[0];
        }
        my $val = $__cache->{$self->id}{$field};
        return @{$val || []} > 1 ? $val : $val->[0];
    }
}

sub GetAttributeValue {
    my ($self, $cfield) = @_;

    my $res = $self->SUPER::GetAttributeValue($cfield) or return;

    my $attribute = $self->attribute($cfield) or do {
        $self->base->log(LA_WARN, "Unknow attribute $cfield");
        return;
    };

    if (my $ref = $attribute->reference) {
        my @deref;
        foreach my $v (ref $res ? @{ $res } : $res) {
            my $derefobj = $self->base->_derefObject($ref, $v);
            push(@deref, $derefobj->id) if ($derefobj);
        }
        return scalar(@deref) > 1 ? \@deref : $deref[0];
    } else {
        return $res;
    }
}

sub set_fields {
    my ($self, %data) = @_;
    my @updated_attributes = ();
    my @fields;
    my @vals;
    my %ext;
    if (exists($data{services})) {
        my %old = map { $_ => 0 } $self->get_attributes('services');
        foreach my $serv (grep { $_ } ref $data{services} ? @{ $data{services} } : $data{services}) {
            if (!exists($old{$serv})) {
                my $oserv = $self->base->get_object('service', $serv) or next;
                $oserv->addAttributeValue('dependOn', $self->type . '.' . $self->id);
            }
            $old{$serv} = 1;
        }
        foreach my $serv (keys %old) {
            if (!$old{$serv}) {
                my $oserv = $self->base->get_object('service', $serv) or next;
                $oserv->delAttributeValue('dependOn', $self->type . '.' . $self->id);
            }
        }
        delete($data{services});
    }
    foreach my $field (keys %data) {
        my $attr = $self->attribute($field);
        my $oldval = $self->get_field($field);
        next if (($data{$field} || '') eq ($oldval || ''));
        if ($attr->{inline}) {
        # TODO check fields exists !
            push(@fields, sprintf("%s = ?", $self->db->quote_identifier($field)));
            # undef mean unset, handling null for exported:
            if ($field eq 'exported') {
                push(@vals, $data{$field} ? 1 : 0);
            } else {
                push(@vals, $data{$field} || undef);
            }
            push(@updated_attributes, $field);
        } else {
            $ext{$field} = $data{$field};
        }
    }
    if (@fields) {
        my $sth = $self->db->prepare_cached(
            sprintf(
                q{update %s set %s where %s = ?},
                $self->_quote_object_table,
                join(', ', @fields),
                $self->_quote_key_field,
            )
        );
        $sth->execute(@vals, $self->id) or do {
            $self->base->log(LA_ERR,
                "Cannot update inline field for object %s, %s: %s",
                $self->type,
                $self->id,
                $self->base->db->errstr);
            return;
        };
    }
    
    if ($self->_has_extended_attributes) {
        my $sthd = $self->db->prepare_cached(
            sprintf(
                q{delete from %s where okey = ? and attr = ?},
                $self->db->quote_identifier($self->_object_table. '_attributes'),
            ),
        );
        my $sthd1 = $self->db->prepare_cached(
            sprintf(
                q{delete from %s where okey = ? and attr = ? and value = ?},
                $self->db->quote_identifier($self->_object_table. '_attributes'),
            ),
        );
        my $sthx = $self->db->prepare_cached(
            sprintf(
                q{insert into %s (okey, attr, value) values (?,?,?)},
                $self->db->quote_identifier($self->_object_table. '_attributes'),
            )
        );
        my $sthu = $self->db->prepare_cached(
            sprintf(
                q{update %s set value = ? where okey = ? and attr = ?},
                $self->db->quote_identifier($self->_object_table. '_attributes'),
            )
        );

        my $okey = $self->_get_ikey($self->base, $self->id);
        foreach my $uattr (keys %ext) {
            my $attr = $self->attribute($uattr);
            if ($ext{$uattr}) {
                if ($attr->{multiple}) {
                    my $updated = 0;
                    my $oldvalue = $self->get_field($uattr);
                    my %newvalues = map { $_ => 1 } (ref $ext{$uattr}
                        ? @{$ext{$uattr}}
                        : $ext{$uattr});
                    foreach (grep { $_ } ref $oldvalue ? @{$oldvalue} : $oldvalue) {
                        if(exists($newvalues{$_})) {
                            $newvalues{$_} = 0;
                        } else {
                            defined($sthd1->execute($okey, $uattr, $_)) or do {
                                $self->base->log(LA_ERR,
                                    "Error while updating attributes on %s/%s %s: %s",
                                    $self->type,
                                    $self->id,
                                    $uattr,
                                    $self->base->db->errstr
                                );
                                return;
                            };
                            $updated++;
                        }
                    }
                    foreach (grep { $newvalues{$_} } keys %newvalues) {
                        $sthx->execute($okey, $uattr, $_) or do {
                            $self->base->log(LA_ERR,
                                "Error while updating attributes: %s/%s %s: %s",
                                $self->type,
                                $self->id,
                                $uattr,
                                $self->base->db->errstr
                            );
                            return;
                        };
                        $updated++;
                    }
                    push(@updated_attributes, $uattr) if ($updated);
                } else {
                    my $res = $sthu->execute($ext{$uattr}, $okey, $uattr);
                    defined($res) or do {
                        $self->base->log(LA_ERR,
                            "Error while udapting attributes: %s/%s %s: %s",
                            $self->type,
                            $self->id,
                            $uattr,
                            $self->base->db->errstr
                        );
                        return;
                    };
                    if ($res == 0) {
                        $res = $sthx->execute($okey, $uattr, $ext{$uattr});
                        defined($res) or do {
                            $self->base->log(LA_ERR,
                                "Error while updating attributes: %s/%s %s: %s",
                                $self->type,
                                $self->id,
                                $uattr,
                                $self->base->db->errstr
                            );
                            return;
                        };
                    }
                    push(@updated_attributes, $uattr);
                }
            } else {
                defined($sthd->execute($okey, $uattr)) or do {
                    $self->base->log(LA_ERR,
                        "Error while deleting attributes: %s/%s %s: %s",
                        $self->otype,
                        $self->id,
                        $uattr,
                        $self->base->db->errstr
                    );
                    return;
                };
                push(@updated_attributes, $uattr);
            }
        }
    }

    delete($self->base->{__cache}{"_" . $self->type}{$self->id});

    foreach my $attr (@updated_attributes) {
        my $oattr = $self->attribute($attr);
        my $ref = $oattr->reference or next;
        my $refname = sprintf('%s.%s.%s', $self->type, $self->id, $attr);
        my $attrref = "oalias=$refname";

        foreach my $alias ($self->base->search_objects($ref, $attrref)) {
            my $oalias = $self->base->GetAlias($ref, $alias) or next;
            $oalias->_update_aliases_cache;
            $oalias->_update_aliases_ptr;
        }
    }

    scalar(@updated_attributes);
}


=head2 SetNoDelete($value)

Set nodelete attribute to true or false

=cut

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

    my $sthr = $self->db->prepare_cached(
        sprintf(
            q{update %s set nodelete = ? where %s = ?},
            $self->db->quote_identifier($self->_object_table),
            $self->db->quote_identifier($self->_key_field),
        )
    );

    if (($sthr->execute($value ? 'true' : 'false', $self->id) || 0) != 1) {
        $self->log(LA_ERR, "Erreur seting nodelete for %s/%s to %s",
            $self->type,
            $self->id,
            $value,
        );
        return;
    }

    1;
}

=head2 find_next_numeric_id($class, $base, $field, $min, $max)

An optimize version to speedup user/group creation

=cut

sub find_next_numeric_id {
    my ($class, $base, $field, $min, $max) = @_;
    $base->attribute($class->type, $field) or return;
    $min ||=
        $field eq 'uidNumber' ? 500 :
        $field eq 'gidNumber' ? 500 :
        1;
    $max ||= 65635;
    $base->log(LA_DEBUG, "Trying to find %s in range %d - %d",
        $field, $min, $max);
    my %existsid;
    $base->temp_switch_unexported(sub {
        foreach ($class->attributes_summary($base, $field)) {
            $existsid{ $_ } = 1;
        }
    }, 1);
    $min += 0;
    $max += 0;
    for(my $i = $min; $i <= $max; $i++) {
        $existsid{$i + 0} or do {
            $base->log(LA_DEBUG, "Next %s found: %d", $field, $i);
            return $i;
        };
    }
    return;
}

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

    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;
    
    my $attr = $base->attribute($class->type, $attribute) or do {
        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
        return;
    };
    if (!$attr->readable) {
        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
        return;
    }
    if (!$base->check_acl($class->type, $attribute, 'r')) {
        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
        return;
    }
    if ($attr->{managed}) { 
        return $class->SUPER::attributes_summary($base, $attribute);
    }
    my $sth = $base->db->prepare_cached(
        $attr->{inline}
            ? sprintf(
                q{select %s as value from %s where internobject = false} . ($base->{wexported} ? '' : ' and "exported" = true'),
                $base->db->quote_identifier($attr->iname),
                $base->db->quote_identifier($class->_object_table),
            )
            : sprintf(
                q{select value from %s join
                %s on %s.ikey = %s.okey where attr = ? and internobject = false group by value} . 
                    ($base->{wexported} ? '' : ' and "exported" = true'),
                $base->db->quote_identifier($class->_object_table),
                $base->db->quote_identifier($class->_object_table .
                    '_attributes'),
                $base->db->quote_identifier($class->_object_table),
                $base->db->quote_identifier($class->_object_table .
                    '_attributes'),
            )
    );
    $sth->execute($attr->{inline} ? () : ($attr->iname));

    my %values;
    if ($recursiveAttr) {
        my $otype = $attr->reference or do {
            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
            return;
        };
        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;

        while (my $res = $sth->fetchrow_hashref) {
            defined($res->{value}) or next;
            $values{ $parentRes{ $res->{value} } } = 1;
        }
    } else {
        while (my $res = $sth->fetchrow_hashref) {
            $values{$res->{value}} = 1 if ($res->{value});
        }
    }
    sort keys %values
}

=head2 attributes_summary_by_object($base, $attribute)

Return a hash containing object/value peer for C<$attribute>.

=cut

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

    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;

    my $attr = $base->attribute($class->type, $attribute) or do {
        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
        return;
    };
    if (!$attr->readable) {
        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
        return;
    }
    if (!$base->check_acl($class->type, $attribute, 'r')) {
        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
        return;
    }

    if ($attr->{managed}) {
        return $class->SUPER::attributes_summary_by_object($base, $attribute);
    }
    my $sth = $base->db->prepare_cached(
        $attr->{inline}
            ? sprintf(
                q{
                select name, %s as value from %s} . ($base->{wexported} ? '' : ' where "exported" = true'),
                $base->db->quote_identifier($attr->iname),
                $base->db->quote_identifier($class->_object_table),
            )
            : sprintf(
                q{select name, value from %s left join %s on %s.ikey = %s.okey and attr = ?} . ($base->{wexported} ? '' : ' and "exported" = true'),
                $base->db->quote_identifier($class->_object_table),
                $base->db->quote_identifier($class->_object_table .
                    '_attributes'),
                $base->db->quote_identifier($class->_object_table),
                $base->db->quote_identifier($class->_object_table .
                    '_attributes'),
            )
    );
    $sth->execute($attr->{inline} ? () : ($attr->iname));

    my %values;
    if ($recursiveAttr) {
        my $otype = $attr->reference or do {
            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
            return;
        };
        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;

        while (my $res = $sth->fetchrow_hashref) {
            defined($res->{value}) or next;
            push(@{ $values{ $res->{name} } }, @{ $parentRes{ $res->{value} } || []});
        }
    } else {
        while (my $res = $sth->fetchrow_hashref) {
            defined($res->{value}) or next;
            push(@{ $values{ $res->{name} } }, $res->{value});
        }
    }
    %values
}

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

    # Results groups by attr (OR filter)
    # foo=1 foo=1 => foo = 1 or foo = 2
    # foo=1 bar=1 => foo =1 and bar = 2
    my $results = {};
    my $noalias = 0;

    @filter = grep { defined($_) && $_ ne '' } @filter;
    if (!@filter) {
        my ($package, $filename, $line) = caller;
        $base->log(LA_DEBUG, "search() call w/o filter at %s:%d", $filename, $line);
        return $base->list_objects($class->type);
    }

    while (my $item = shift(@filter)) {
        # attr=foo => no extra white space !
        # \W is false, it is possible to have two char
        my ($attr, $attrref, $operator, $val) = $item =~ /^(\w+)(?:\.([\.\w]+))?(?:([^\w*]+)(.+))?$/ or next;
        if (!$operator) {
            $operator = '~';
            $val = shift(@filter);
        }
        my $attribute = $base->attribute($class->type, $attr) or do {
            $base->log(LA_ERR, "Unknown attribute $attr");
            return;
        };
        $attribute->name eq 'oalias' and $noalias = 1;
        defined($val) or $val =  '';

        $base->log(LA_DEBUG, "Search for %s %s (ref %s) %s %s", $class->type, $attr, $attrref || '(none)', $operator || '', $val);

        # Invalid filter due to impossible value:
        if ($operator ne '~' && !($operator eq '=' && ($val eq 'NULL' || $val eq '*'))) {
            if (!$attribute->checkinputformat($val)) {
                $base->log(LA_ERR, "Invalid format value $val for attribute $attr");
                return;
            }
        }
        my $attrKey = $attr;

        if ($attrref) {
            my $otype = $attribute->reference or do {
                $base->log(LA_ERR, "Attribute $attr do not refer to another object");
                return;
            };

            $attrKey .= '.' . $attrref;
            my @results = $base->search_objects($otype, "$attrref$operator$val");
            $base->log(LA_DEBUG, "Sub search %s res: %s", $otype, join(', ', @results));

            if (!@results) {
                $results->{$attrKey} ||= {};
                next;
            }

            ($operator, $val) = ('=', join('||', @results));
        }

        my @results = $class->_search_uniq_filter($base, $attr, $operator, $val);

        $base->log(LA_DEBUG, "Search result: %s: %s", $attr, join(' ', @results));
        $results->{$attrKey} ||= {};
        $results->{$attrKey}{$_} = 1 foreach (@results);
    }

    # Merging filter result

    my %mresults = map { $_ => 1 } $base->list_objects($class->type);

    foreach my $attr (keys %{ $results }) {
        my @values = keys %mresults;
        foreach my $value (sort(@values)) {
            if (!$results->{$attr}{$value}) {
                delete($mresults{$value});
            }
        }
    }

    # We add to result aliases pointing to these object:
    if(scalar(keys %mresults) && !$noalias) {
        my @alias = $class->_search_uniq_filter($base, 'oalias', '=', join('||', keys %mresults));
        foreach(@alias) {
            $mresults{$_} = 1;
        }
    }

    return(sort keys %mresults);
}

sub _search_uniq_filter {
    my ($class, $base, $attr, $operator, $value) = @_;

    my @attrsql;
    my @attrbind;

    my $attribute = $base->attribute($class->type, $attr) or do {
        $base->log(LA_ERR, "Unknown attribute $attr");
        return;
    };

    my @values = split(/([\|\&]+)/, $value);

    $base->log(LA_DEBUG, "Uniq search for " . $class->type . "->$attr $operator (%s)", join(' ', @values));

    return unless(@values);
    
    # We detect if we can do a very quick search:
    my $forRef = $operator eq '=' && scalar(@values) > 1 && ! grep { $_ eq '*' or $_ eq  '&&' or $_ eq 'NULL' } @values;
    if ($forRef) {
        # Improv perf

        my @oaliases = ();
        if ($attr ne 'oaliascache' && $attribute->reference) {
            @oaliases = $base->search_objects($attribute->reference, "oaliascache=$value");
            $base->log(LA_DEBUG, "Uniq search will match oaliases: %s", join(' ', @oaliases) || '(none)');
        }

        if ($attribute->{inline}) {
            my $sql = sprintf(
                q{select ikey from %s where %s = ANY (?)},
                $base->db->quote_identifier($class->_object_table),
                $base->db->quote_identifier($attribute->iname),
            );
            push(@attrsql, $sql);
        } else {
            my $sql = sprintf(
                q{select okey from %s where attr = ? and "value" = ANY (?) },
                    $base->db->quote_identifier($class->_object_table . '_attributes'),
            );
            push(@attrbind, $attribute->iname);
            push(@attrsql, $sql);
        }
        push(@attrbind, [ @oaliases, grep { $_ ne '||' } @values ]);
    } else {

    # No optimisation possible:
    while (defined(my $val = shift(@values))) {

        if ($val eq '&&') {
            push(@attrsql, 'intersect');
            next;
        }
        if ($val eq '||') {
            push(@attrsql, 'union');
            next;
        }

        $val = $attribute->input($val) unless($operator eq '=' && $val eq 'NULL');

        my $sql;

        # Specific case for unexported attribute, comming from exported value
        if ($attribute->iname eq 'unexported') {
            $sql = sprintf(
                q{select ikey from %s where %s},
                $base->db->quote_identifier($class->_object_table),
                $val ? q{exported='f'} : q{exported='t'}
            )
        } elsif ($attribute->iname eq 'exported') {
            $sql = sprintf(
                q{select ikey from %s where %s},
                $base->db->quote_identifier($class->_object_table),
                $val ? q{exported='t'} : q{exported='f'}
            )
        } elsif ($attribute->{inline}) {
            $sql = sprintf(
                q{select ikey from %s where %s%s %s},
                $base->db->quote_identifier($class->_object_table),
                $base->db->quote_identifier($attribute->iname),
                ($operator eq '~' ? '::text' : ''),
                $operator eq '=' && $val eq '*'
                    ? 'is not NULL'
                    : $operator eq '=' && $val eq 'NULL'
                    ? 'is NULL'
                    : $operator eq '~'
                        ? 'ILIKE ?'
                        : "$operator ?"
            );
            push(@attrbind, $operator eq '~' ? '%' . $val . '%' : $val) unless($operator eq '=' && ($val eq '*' || $val eq 'NULL'));
        } else {
            if ($operator eq '=' && $val eq 'NULL') {
                $sql = sprintf(q{ select ikey from %s where ikey
                          not in (select okey from %s where attr = ? and ("value" is NOT NULL and value != '')) },
                          $base->db->quote_identifier($class->_object_table),
                          $base->db->quote_identifier(
                              $class->_object_table . '_attributes'
                          ),
                );
                push(@attrbind, $attribute->iname);
            } else {
                my @oaliases = ();
                if ($attr ne 'oaliascache' && $attribute->reference) {
                    @oaliases = $base->search_objects($attribute->reference, "oaliascache=$val");
                    $base->log(LA_DEBUG, "Uniq search will match oaliases for %s: %s", $val, join(' ', @oaliases) || '(none)');
                }

                $sql = sprintf(
                    q{select okey from %s where attr = ? %s},
                    $base->db->quote_identifier(
                        $class->_object_table . '_attributes'
                    ),
                    $val eq '*'
                        ? ''
                        : $operator eq '~'
                            ? q{and value::text ILIKE ANY(?)}
                            : qq{and value $operator ANY (?)}

                );
                push(@attrbind, $attribute->iname);
                my @vals = ( $val, @oaliases );
                push(@attrbind, $operator eq '~'
                    ? [ map { '%' . $_ . '%' } @vals ]
                    : [ @vals ])
                    unless($val eq '*');
            }
        }

        push(@attrsql, $sql);
    }

    } # Perf

    # building the query
    if (!$base->{wexported}) {
        push(@attrsql, 'intersect') if (@attrsql);
        push(@attrsql, sprintf(
                q{select ikey from %s where exported = true and internobject = false},
                $base->db->quote_identifier($class->_object_table)
            )
        );
    }
    my $sth = $base->db->prepare(
        sprintf(q{
            select name from %s
            where internobject = false
            %s
            order by name
            },
            $base->db->quote_identifier($class->_object_table),
            @attrsql
            ? "and ikey in (\n" . join(" ", @attrsql) . ")\n"
            : '',
        )
    );
    $sth->execute(@attrbind);
    my @results;
    while (my $res = $sth->fetchrow_hashref) {
        push(@results, $res->{name});
    }
    return(@results);
}

=head2 register_attribute

Register attribute into base

=cut

sub register_attribute {
    my ($class, $base, $attribute, $comment) = @_;

    $class->is_registered_attribute($base, $attribute) and do {
        $base->log(LA_ERR, "The attribute $attribute already exists");
        return;
    };
    my $sth = $base->db->prepare(
        sprintf(q{
            insert into %s (canonical, description)
            values (?,?)
            }, $class->_attributes_table)
    );
    my $res = $sth->execute($attribute, $comment);
}

=head2 is_registered_attribute ($base, $attribute)

Return true is attribute is registered into base

=cut

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

    my $sth = $base->db->prepare(
        sprintf(q{
            select 1 from %s where canonical = ?
            }, $class->_attributes_table
        )
    );
    $sth->execute($attribute);
    my $res = $sth->fetchrow_hashref;
    return $res ? 1 : 0;
}

=head2 list_registered_attributes

Return the list for all registered attribute

=cut

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

    my $sth = $base->db->prepare(
        sprintf(q{
            select canonical from %s
            }, $class->_attributes_table
        )
    );
    $sth->execute();
    my @attrs = ();

    while (my $res = $sth->fetchrow_hashref) {
        push(@attrs, $res->{canonical});
    }
    return @attrs;
}


=head2 get_attribute_comment $base, $attribute)

Return comment for C<$attribute>

=cut

# TODO: get_attribute_comment($attr, $base) { $base ||= $self->base ...

sub get_attribute_comment {
    my ($class, $base, $attribute) = @_;
    $base->attribute($class->type, $attribute) or do {
        $base->log(LA_ERR, "The attribute $attribute does not exists");
        return;
    };
    my $sth = $base->db->prepare(
        sprintf(q{
            select description from %s
            where canonical = ?
            }, $class->_attributes_table)
    );
    $sth->execute($attribute);
    if (my $res = $sth->fetchrow_hashref) {
        $sth->finish;
        return $res->{description};
    } else {
        return;
    }
}

=head2 set_attribute_comment ($base, $attribute, $comment)

Set comment to attribute

=cut

sub set_attribute_comment {
    my ($class, $base, $attribute, $comment) = @_;

    my $attr = $base->attribute($class->type, $attribute) or do {
        $base->log(LA_ERR, "The attribute $attribute does not exists");
        return;
    };
    $attr->{inline} and do {
        $base->log(LA_ERR,
            "Cannot set comment to inline attribute, sorry, blame the author !"
        );
        return;
    };
    my $sth = $base->db->prepare(
        sprintf(q{
            update %s set description = ?
            where canonical = ?
            }, $class->_attributes_table)
    );
    my $res = $sth->execute($comment, $attribute);
}

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

    my $atype = $self->type;
    my $name  = $self->id;
    my $base  = $self->base;

    foreach my $otype ($base->list_supported_objects) {
        foreach my $attr ($base->list_canonical_fields($otype, 'r')) {
            $attr =~ /^(oalias|modifiedby|createdby)$/ and next;
            my $attribute = $base->attribute($otype, $attr);
            my $ref = $attribute->reference or next;

            if ($ref eq $atype) {
                $base->log(LA_DEBUG, "Searching object referencing alias %s/%s in %s->%s",
                    $atype, $name, $otype, $attr);
                foreach my $target ($base->search_objects($otype, "$attr\=$name", 'oalias=NULL')) {
                    $base->log(LA_DEBUG, "Update ref for object %s/%s", $otype, $target);
                    my $otarget = $base->get_object($otype, $target) or next;
                    $otarget->refreshRev;
                    if ($otype eq 'group' && grep { $_ eq 'dpmt' } $otarget->_get_attributes('sutype')) {
                        $otarget->_update_employment_manager;
                    }
                }
            }
        }
    }
}

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

    my $getoalias = $self->base->db->prepare(
        sprintf(
            q{ select * from %s where %s = ? },
            $self->base->db->quote_identifier($self->_object_table),
            $self->base->db->quote_identifier($self->_key_field),
        )
    );
    $getoalias->execute($self->id);
    my $res = $getoalias->fetchrow_hashref or do {
        $self->base->log(LA_ERR, "Cannot find alias %s / %s", $self->type, $self->id);
        return;
    };
    $getoalias->finish;

    my $ref = $self->base->_derefObject($self->type, $res->{oalias});
    my $id = $ref ? $ref->id : undef;

    if (($id || '') ne ($res->{oaliascache} || '')) {
        my $upd = $self->base->db->prepare(
            sprintf(
                q{update %s set oaliascache = ? where %s = ?},
                $self->base->db->quote_identifier($self->_object_table),
                $self->base->db->quote_identifier($self->_key_field),
            )
        );
        $self->base->log(LA_DEBUG, "Updating Cache for alias %s => %s", $self->id, $id || '(none)');
        return $upd->execute($id, $self->id);
    }
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Bases::Sql>

L<LATMOS::Accounts::Bases::Objects>

=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
