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

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

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases);
use LATMOS::Accounts::Log;
use DBI;
use Crypt::RSA;
use Crypt::RSA::Key::Public::SSH;
use Crypt::RSA::Key::Private::SSH;
use Crypt::RSA::Key::Public;
use Crypt::RSA::Key::Private;
use Crypt::Blowfish;
use MIME::Base64;

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

sub SCHEMA_VERSION { 28 };

=head1 NAME

LATMOS::Ad - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases;
  my $base = LATMOS::Accounts::Bases->new('unix');
  ...

=head1 DESCRIPTION

Account base access over standard unix file format.

=head1 FUNCTIONS

=cut

=head2 SCHEMA_VERSION

Return the SQL schema version to use for this software version.

=head2 new(%config)

Create a new LATMOS::Ad object for windows AD $domain.

domain / server: either the Ad domain or directly the server

ldap_args is an optionnal list of arguments to pass to L<Net::LDAP>.

=cut

sub new {
    my ($class, %config) = @_;
    
    my $base = {
        db_conn => $config{db_conn},
    };

    bless($base, $class);
}

sub DESTROY {
    my ($self) = @_;
    $self->{_db} && $self->{_db}->rollback;
}

=head2 db

Return a L<DBI> handle over database, load it if need.

=cut

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

    if ($self->{_db} && $self->{_db}->ping) {
        return $self->{_db};
    } else {
        $self->{_db} = DBI->connect_cached(
            'dbi:Pg:' . $self->{db_conn},
            undef, undef,
            {
                RaiseError => 0,
                AutoCommit => 0,
                PrintWarn => 1,
                PrintError => 1,
            }
        ) or do {
            $self->log(LA_ERR, "Cannot connect to database: %s", $DBI::errstr);   
            return;
        };
        $self->{_db}->do(q{set DATESTYLE to 'DMY'});
        $self->log(LA_DEBUG, 'New connection to DB');

        {
            my $sv = $self->get_global_value('schema_version') || 1;
            if ($sv < SCHEMA_VERSION) {
                require LATMOS::Accounts::Bases::Sql::upgrade;
                if ($self->SchemaUpgrade()) {
                    $self->commit;
                } else {
                    $self->rollback;
                    return;
                }
            }
        }

        foreach my $otype ($self->list_supported_objects) {
            my %attrlist = map { $_ => 1 } $self->list_registered_attributes($otype);
            foreach my $attribute ($self->list_canonical_fields($otype, 'a')) {
                my $attr = $self->attribute($otype, $attribute);
                $attr->{inline} and next;
                $attr->{managed} and next;

                if ($attrlist{$attribute}) {
                } else {
                    if($self->register_attribute($otype, $attribute, $attr->{comment})) {
                        $self->log(LA_NOTICE, "Attr. $attribute for object type $otype registred");
                    } else {
                        $self->log(LA_ERR, "Can't register attribute $attribute");
                        $self->{_db}->rollback;
                        return;
                    }
                }
            }
        }

        $self->{_db}->commit;
        return $self->{_db};
    }
}

=head2 load

Read file and load data into memory

=cut

sub load {
    my ($self) = @_;
    if (!$self->db) { return 0 };

    my $sv = $self->get_global_value('schema_version') || 1;
    if ($sv < SCHEMA_VERSION) {
        $self->log(LA_CRIT,
            "Schema version %d found, %d is need, please update db using " .
            "`la-sql-upgrade' tool for `%s' base",
            $sv,
            SCHEMA_VERSION,
            $self->label,
        );
        # return;
    }
    $self->_CreateInternalObjects;

    1;
}

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

    my $dbi = $self->{_db};

    my @objects = (
        {
            name => 'dpmt',
            otype => 'sutype',
            attrs => {
                description => 'Department',
            },
        },
        {
            name => 'contrattype',
            otype => 'sutype',
            attrs => {
                description => 'Contract',
            },
        },
        {
            name => '-useralias',
            otype => 'group',
            attrs => {
                description => 'Internal group for user alias object',
                gidnumber => -1,
                unexported => 1,
            },
            intern => 1,
        },
    );

    $self->temp_switch_unexported( sub {

            my $setnodel  = $dbi->prepare('UPDATE objects SET nodelete     = true where name = ?');
            my $setintern = $dbi->prepare('UPDATE objects SET internobject = true where name = ?');

            foreach (@objects) {
                if (!$self->GetRawObject($_->{otype}, $_->{name})) {
                    printf("Creating object %s/%s\n", $_->{otype}, $_->{name});
                    $self->create_object($_->{otype}, $_->{name}, %{$_->{attrs} || {}})
                        or warn sprintf("cannot create %s/%s\n", $_->{otype}, $_->{name});

                }

                $setnodel->execute($_->{name});
                $setintern->execute($_->{name}) if ($_->{intern});
            }

    }, 1);
    $self->commit;

    return 1;
}

=head2 ListInternalObjects($otype)

List objects flags as internal for type C<$otype>

=cut

sub ListInternalObjects {
    my ($self, $otype) = @_;

    my $pclass = $self->_load_obj_class($otype) or return;

    # Object Alias: checking if object is alias, then returning it:
    my $sth = $self->db->prepare_cached(
        sprintf(q{select %s as k from %s where and internobject = true},
            $self->db->quote_identifier($pclass->_key_field),
            $self->db->quote_identifier($pclass->_object_table),
        ),
    );
    $sth->execute();
    my @list;
    while (my $res = $sth->fetchrow_hashref) {
       push(@list, $_->{k});
   }
   return(@list);
}

=head2 GetRawObject($otype, $id)

Return an object even it is internal, alias are not follow and even
unexported object are returned

This function must be used only for maintenance operation.

=cut

sub GetRawObject {
    my ($self, $otype, $id) = @_;

    my $pclass = $self->_load_obj_class($otype) or return;

    return $self->SUPER::get_object($otype, $id);
}

sub _derefObject {
    my ($self, $otype, $oalias) = @_;
    $oalias or return;
    if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) {
        my $attribute = $self->attribute($aliasotype, $aliasattr) or do {
            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s",
                $otype, $oalias, $aliasotype, $aliasattr);
            return;
        };
        my $refotype = $attribute->reference or do {
            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object",
                $otype, $oalias);
            return;
        };
        $refotype eq $otype or do {
            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference same object type",
                $otype, $oalias, $refotype);
            return;
        };
        my $robj = $self->get_object($aliasotype, $aliasoname) or do {
            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch object %s/%s",
                $otype, $oalias, $aliasotype, $aliasoname);
            return;
        };
        my $rvalue = $robj->get_attributes($aliasattr) or do {
            $self->log(LA_DEBUG, "Oalias %s (%s): attribute value is empty",
                $otype, $oalias);
            return;
        };
        return $self->get_object($refotype, $rvalue);
    } else {
        return $self->get_object($otype, $oalias);
    }
}

sub get_object {
    my ($self, $otype, $id) = @_;

    my $pclass = $self->_load_obj_class($otype) or return;

    # Object Alias: checking if object is alias, then returning it:
    my $sth = $self->db->prepare_cached(
        sprintf(q{select oalias from %s where %s = ? and internobject = false %s},
            $self->db->quote_identifier($pclass->_object_table),
            $self->db->quote_identifier($pclass->_key_field),
            ($self->{wexported} ? '' : 'and exported = true'),
        ),
    );
    $sth->execute($id);
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    if (my $oalias = $res->{oalias}) {
        # Cross reference over object/attribute
        $self->_derefObject($otype, $oalias);
    } else {
        return $self->SUPER::get_object($otype, $id);
    }
}

=head2 getObjectFromOKey ($okey)

Return the object from the db internal key

=cut

sub getObjectFromOKey {
    my ($self, $okey) = @_;

    my $findobj = $self->{_db}->prepare_cached(q{
        select * from objects_table where ikey = ?
    });

    $findobj->execute($okey);

    my $res = $findobj->fetchrow_hashref;
    $findobj->finish;

    if ($res) {
        return $self->get_object($res->{relname}, $res->{name});
    } else {
        return;
    }
}

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

    my @groups = $self->search_objects('group', 'autoMemberFilter=*');

    my $res = 0;
    foreach (@groups) {
        my $g = $self->get_object('group', $_) or next;
        $res += $g->populate_dyn_group;
    }

    $self->log(LA_DEBUG, "Group Dyn res %d", $res);
    $res
}

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

    my @groups = $self->search_objects('aliases', 'autoMemberFilter=*');

    my $res = 0;
    foreach (@groups) {
        my $g = $self->get_object('aliases', $_) or next;
        $res += $g->populate_dyn_aliases;
    }

    $self->log(LA_DEBUG, "Aliases Dyn res %d", $res);
    $res
}

=head2 PopulateDynData

Recomputate dynamics attributes (autoMembersFilters) if need

=cut

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

    $self->temp_switch_unexported(sub {

        foreach (1 .. 5) {
            $self->log(LA_DEBUG, "%d loop for PopulateDynData", $_);
            my $res = 0;
            $res += $self->_sync_dyn_group   || 0;
            $res += $self->_sync_dyn_aliases || 0;

            if ($res == 0) {
                last;
            }
        }

    }, 0);

    return 1;
}

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

    $self->PopulateDynData;

    if ($ENV{LA_NO_COMMIT}) {
        $self->log(LA_DEBUG, 'DB::COMMIT (ignore due to LA_NO_COMMIT)');
        return 1;
    } else {
        $self->log(LA_DEBUG, 'DB::COMMIT');
    }
    $self->{__cache} = undef;
    $self->db->commit;
}

sub _rollback {
    my ($self) = @_;
    if ($ENV{LA_NO_COMMIT}) {
        $self->log(LA_DEBUG, 'DB::ROLLBACK (ignore due to LA_NO_COMMIT)');
        return 1
    } else {
        $self->log(LA_DEBUG, 'DB::ROLLBACK');
    }
    $self->{__cache} = undef;
    $self->db->rollback;
}

sub list_supported_objects {
    my ($self, @otype) = @_;
    $self->SUPER::list_supported_objects(qw(site), @otype);
}

# For SQL listRealObjects != list_objects
sub listRealObjects {
    my ($self, $otype) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->listReal($self);
}

sub current_rev {
    my ($self) = @_;
    my $sth = $self->db->prepare_cached(
        q{select max(rev) from revisions}
    );
    $sth->execute;
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    return ($res->{max});
} 

sub authenticate_user {
    my ($self, $username, $passwd) = @_;
    $username or return;
    my $uobj = $self->get_object('user', $username) or do {
        la_log(LA_ERR, "Cannot authenticate non existing SQL user $username");
        return;
    };

    if ($self->attribute('user', 'exported')) {
        if (!$uobj->_get_c_field('exported')) {
            la_log(LA_ERR, "User $username found but currently unexported");
            return;
        }
    }

    $self->SUPER::authenticate_user($username, $passwd);
}

=head1 SPECIFICS FUNCTIONS

=head2 GetAlias($base, $id)

Return object having id C<$id> only if it is an object alias

=cut

sub GetAlias {
    my ($self, $otype, $id) = @_;

    my $pclass = $self->_load_obj_class($otype) or return;

    # Object Alias: checking if object is alias, then returning it:
    my $sth = $self->db->prepare_cached(
        sprintf(q{select oalias from %s where %s = ? and oalias IS NOT NULL and internobject = false %s},
            $self->db->quote_identifier($pclass->_object_table),
            $self->db->quote_identifier($pclass->_key_field),
            ($self->{wexported} ? '' : 'and exported = true'),
        ),
    );
    $sth->execute($id);
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    if ($res) {
        return $self->SUPER::get_object($otype, $id);
    } else {
        return;
    }
}

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

Create an object alias named C<$name> for ovbject C<$for>

=cut

sub CreateAlias {
    my ($self, $otype, $name, $for) = @_;

    my $pclass = $self->_load_obj_class($otype) or return;

    $for or die "Cannot create alias without giving object to point";

    my $res = $pclass->CreateAlias($self, $name, $for);

    if ($res) {
        $self->ReportChange(
            $otype,
            $name,
            $pclass->_get_ikey($self, $name),
            'Create', "Alias %s %s => %s", $otype, $name, $for
        );
        $self->log(LA_DEBUG, "Alias $otype $name => $for created");
        my $oalias = $self->GetAlias($otype, $name);
        $oalias->_update_aliases_ptr();
        return 1;
    } else {
        $self->log(LA_ERR, "Error when creating alias $otype $name");
        return;
    }
}

=head2 RenameAlias($otype, $name, $to)

Rename an object alias

=cut

sub RenameAlias {
    my ($self, $otype, $name, $to) = @_;

    my $pclass = $self->_load_obj_class($otype) or return;

    my $obj = $self->GetAlias($otype, $name) or do {
        $self->log('Cannot get alias %s/%s for removal', $otype, $name);
        return;
    };

    my $sth = $self->db->prepare_cached(sprintf(
        'UPDATE %s SET %s = ? WHERE %s = ?',
        $self->db->quote_identifier($pclass->_key_field),
        $self->db->quote_identifier($pclass->_object_table),
        $self->db->quote_identifier($pclass->_key_field),
    ));

    my $res = $sth->execute($to, $name);

    return $res;
}

=head2 RemoveAlias($otype, $name, $for)

Create an object alias named C<$name> for ovbject C<$for>

=cut

sub RemoveAlias {
    my ($self, $otype, $name) = @_;

    my $pclass = $self->_load_obj_class($otype) or return;

    my $obj = $self->GetAlias($otype, $name) or do {
        $self->log('Cannot get alias %s/%s for removal', $otype, $name);
        return;
    };

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

    my $id = $obj->Iid;

    my $sth = $self->db->prepare_cached(sprintf(
        'DELETE FROM %s WHERE %s = ?',
        $self->db->quote_identifier($pclass->_object_table),
        $self->db->quote_identifier($pclass->_key_field),
    ));

    $obj->_update_aliases_ptr;
    my $res = $sth->execute($name);

    if ($res) {
        $self->ReportChange(
            $otype,
            $name,
            $id,
            'Delete', "Alias %s %s deleted", $otype, $name
        );
        $self->log(LA_DEBUG, "Alias $otype $name removed");
        return 1;
    } else {
        $self->log(LA_ERR, "Error when removing alias $otype $name");
        return;
    }
}

=head2 get_global_value ($varname)

Return global value set into base

=cut

sub get_global_value {
    my ($self, $varname) = @_;

    my $sth = $self->db->prepare_cached(q{
        select val from settings where varname = ?
        });
    $sth->execute($varname);
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    $res->{val}
}

=head2 set_global_value ($varname, $value)

Set global value.

=cut

sub set_global_value {
    my ($self, $varname, $value) = @_;
    my $sth = $self->db->prepare(q{
        update settings set val = ? where varname = ?
        });
    $sth->execute($value, $varname) == 0 and do {
        my $sth2 = $self->db->prepare(q{
            insert into settings (val, varname) values (?,?)
            });
        $sth2->execute($value, $varname);
    };
}

=head2 del_global_value ($varname)

Delete global value from base

=cut

sub del_global_value {
    my ($self, $varname) = @_;

    my $sth = $self->db->prepare_cached(q{
        delete from settings where varname = ?
        });
    return $sth->execute($varname);
}

=head2 generate_rsa_key ($password)

Return public and private peer rsa keys

=cut

sub generate_rsa_key {
    my ($self, $password) = @_;

    my $rsa = new Crypt::RSA ES => 'PKCS1v15';
    my ($public, $private) = $rsa->keygen (
        Identity  => 'LATMOS-Accounts',
        Size      => 2048,
        Password  => $password,
        Verbosity => 0,
    ) or die $rsa->errstr(); # TODO avoid die
    return ($public, $private);
}

=head2 private_key ($password)

Load and return private rsa key

=cut

sub private_key {
    my ($self, $password) = @_;
    my $base = $self;
    my $serialize = $base->get_global_value('rsa_private_key') or return;
    my $string = decode_base64($serialize);
    my $privkey = $string =~ /^SSH PRIVATE KEY FILE/
        ? Crypt::RSA::Key::Private::SSH->new
        : Crypt::RSA::Key::Private->new;
    $privkey = $privkey->deserialize(
        String => [ $string ],
        Password => $password
    );
    $privkey->reveal( Password => $password );
    $privkey;
}

=head2 get_rsa_password

Return hash with peer username => encryptedPassword

=cut

sub get_rsa_password {
    my ($self) = @_;
    my $base = $self;
    my $sth = $base->db->prepare(q{
        select "name", value from "user" join user_attributes_base
        on "user".ikey = user_attributes_base.okey
        where user_attributes_base.attr = 'encryptedPassword'
    });
    $sth->execute;
    my %users;
    while (my $res = $sth->fetchrow_hashref) {
        $users{$res->{name}} = $res->{value};
    }
    %users
}

=head2 store_rsa_key ($public, $private)

Store public and private RSA key info data base

=cut

sub store_rsa_key {
    my ($self, $public, $private) = @_;
    my $base = $self;
    $private->hide;
    $base->set_global_value('rsa_private_key',
        encode_base64($private->serialize));
    $base->set_global_value('rsa_public_key',
        $public->serialize);
    return;
}

=head2 find_next_expire_users ($expire)

Search user expiring in C<$expire> delay

=cut

sub find_next_expire_users {
    my ($self, $expire) = @_;

    my $sth= $self->db->prepare(q{
        select name from "user" where
            expire < now() + ?::interval
            and expire > now()
            and expire is not null
            and internobject = false
            } . ($self->{wexported} ? '' : 'and exported = true') . q{
            order by expire
        }
    );
    $sth->execute($expire || '1 month');
    my @users;
    while (my $res = $sth->fetchrow_hashref) {
        push(@users, $res->{name});
    }
    @users
}

=head2 find_expired_users ($expire)

Return list of user going to expires in C<$expire> delay

=cut

sub find_expired_users {
    my ($self, $expire) = @_;

    my $sth= $self->db->prepare(q{
        select name from "user" where
            expire < now() - ?::interval
            and expire is not null
            and internobject = false
        } . ($self->{wexported} ? '' : 'and exported = true') . q{
            order by expire
        }
    );
    $sth->execute($expire || '1 second');
    my @users;
    while (my $res = $sth->fetchrow_hashref) {
        push(@users, $res->{name});
    }
    @users
}

=head2 rename_nethost ($nethostname, $to, %config)

Facility function to rename computer to new name

=cut

sub rename_nethost {
    my ($self, $nethostname, $to, %config) = @_;
    {
        my $obj = $self->get_object('nethost', $nethostname) or do {
            $self->log(LA_ERR, 'Unable to rename non exisant host %s', $nethostname);
            return;
        };
        $obj->_delAttributeValue(cname => $to);
    }
    $self->rename_object('nethost', $nethostname, $to) or return;
    if ($config{'addcname'}) {
        my $obj = $self->get_object('nethost', $to);
        $obj->_addAttributeValue(cname => $nethostname);
    }
    return 1;
}

=head2 nethost_exchange_ip ($ip1, $ip2)

Exchange ip1 with ip2 in base

=cut

sub nethost_exchange_ip {
    my ($self, $ip1, $ip2) = @_;
    my ($obj1, $obj2);
    if (my ($host1) = $self->search_objects('nethost', "ip=$ip1")) {
        $obj1 = $self->get_object('nethost', $host1);
    } else {
        $self->log(LA_ERR, "Cannot find host having $ip1");
        return;
    }
    if (my ($host2) = $self->search_objects('nethost', "ip=$ip2")) {
        $obj2 = $self->get_object('nethost', $host2);
    } else {
        $self->log(LA_ERR, "Cannot find host having $ip2");
        return;
    }
    if ($obj1->id eq $obj2->id) {
        $self->log(LA_ERR, "Both ip belong to same host (%s)", $obj1->id);
        return;
    }

    $self->log(LA_NOTICE, "Exchanging IP between %s and %s", $obj1->id, $obj2->id);
    $obj1->delAttributeValue('ip', $ip1) ;
    $obj2->delAttributeValue('ip', $ip2) ;
    $obj1->addAttributeValue('ip', $ip2) ;
    $obj2->addAttributeValue('ip', $ip1) ;
    return 1;
}

=head1 ATTRIBUTES FUNCTIONS

=cut

sub obj_attr_allowed_values {
    my ($self, $otype, $attr) = @_;
    if (my @values = $self->SUPER::obj_attr_allowed_values("$otype.$attr", 'allowed')) {
        return @values;
    } else {
        $self->ListAttrValue($otype, $attr);
    }
}

=head2 ListAttrValue($otype, $attribute)

List values allow for an attribute set into SQL database

=cut

sub ListAttrValue {
    my ($self, $otype, $attr) = @_;

    my @sqlvalues;
    my $getAllow = $self->db->prepare_cached(q{
        SELECT * FROM attributes_values WHERE otype = ? AND attributes = ?
        ORDER BY "value"
    });
    $getAllow->execute($otype, $attr);
    while (my $res = $getAllow->fetchrow_hashref) {
        push(@sqlvalues, $res->{value});
    }
    return @sqlvalues;
}

=head2 AddAttrValue($otype, $attr, @values)

Add given values to allowed attribute list

=cut

sub AddAttrValue {
    my ($self, $otype, $attr, @values) = @_;
    
    my $addAllow = $self->db->prepare_cached(q{
        INSERT INTO attributes_values (otype, attributes, "value") values (?,?,?)
    });
    
    foreach my $value (@values) {
        if ($addAllow->execute($otype, $attr, $value)) {
        } else {
            $self->rollback;
            return;
        }
    }

    return 1;
}

=head2 DelAttrValue

Delete a

=cut

sub DelAttrValue {
    my ($self, $otype, $attr, @values) = @_;

    if (@values) {
        my $delAllow = $self->db->prepare_cached(q{
            DELETE FROM attributes_values WHERE otype = ? and attributes = ? and "value" = ?
        });

        foreach my $value (@values) {

            if ($delAllow->execute($otype, $attr, $value)) {
            } else {
                $self->rollback;
                return;
            }

        }
        return 1;
    } else {
        my $delAllow = $self->db->prepare_cached(q{
            DELETE FROM attributes_values WHERE otype = ? and attributes = ?
        });
        if ($delAllow->execute($otype, $attr)) {
            return 1;
        } else {
            $self->rollback;
            return;
        }
    }
}

=head2 register_attribute ($otype, $attribute, $comment)

Register a new attribute in base

=cut

sub register_attribute {
    my ($self, $otype, $attribute, $comment) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->register_attribute($self, $attribute, $comment);
}

=head2 is_registered_attribute ($otype, $attribute)

Return true is attribute already exists

=cut

sub is_registered_attribute {
    my ($self, $otype, $attribute) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->is_registered_attribute($self, $attribute);
}

=head2 list_registered_attributes ($otype)

List all regiestered attribute

=cut

sub list_registered_attributes {
    my ($self, $otype) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    if ($pclass->_has_extended_attributes) {
        return $pclass->list_registered_attributes($self);
    } else {
        return ();
    }
}

=head2 get_attribute_comment ($otype, $attribute)

Return the comment associated to attribute

=cut

sub get_attribute_comment {
    my ($self, $otype, $attribute) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->get_attribute_comment($self, $attribute);
}

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

Set comment to attribute

=cut

sub set_attribute_comment {
    my ($self, $otype, $attribute, $comment) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->set_attribute_comment($self, $attribute, $comment);
}

=head2 getEmploymentRange

Return date range within employment can be found in database

=cut

sub getEmploymentRange {
    my ($self, @filters) = @_;

    my ($min,$max);

    if (@filters) {
        my @flist = $self->search_objects('employment', @filters);
        my $minSql = $self->db->prepare(q{
            SELECT min(firstday) as min FROM employment
            WHERE name = ANY (?)
        });
        $minSql->execute(\@flist);
        if (my $res = $minSql->fetchrow_hashref) {
            $min = $res->{min}
        }
        my $maxSql = $self->db->prepare(q{
            SELECT max(lastday) as max FROM employment
            WHERE name = ANY (?)
        });
        $maxSql->execute(\@flist);
        if (my $res = $maxSql->fetchrow_hashref) {
            $max = $res->{max}
        }
    } else {
        my $minSql = $self->db->prepare(q{
            SELECT min(firstday) as min FROM employment
        });
        $minSql->execute;
        if (my $res = $minSql->fetchrow_hashref) {
            $min = $res->{min}
        }
        my $maxSql = $self->db->prepare(q{
            SELECT max(lastday) as max FROM employment
        });
        $maxSql->execute;
        if (my $res = $maxSql->fetchrow_hashref) {
            $max = $res->{max}
        }
    }

    return ($min,$max);
}

sub ReportChange {
    my ($self, $otype, $name, $ref, $changetype, $message, @args) = @_;

    my $sthmodifiedby = $self->db->prepare(q{
        UPDATE objects set modifiedby = ? where ikey = ?
    });

    $sthmodifiedby->execute(
        $self->user || '@Console',
        $ref,
    );

    my $sth = $self->db->prepare(q{
        INSERT into objectslogs (ikey, irev, otype, name, changetype, username, message)
        VALUES (?,?,?,?,?,?,?)
        });

    $sth->execute(
        $ref,
        $self->current_rev,
        $otype,
        $name,
        $changetype,
        $self->user || '@Console',
        sprintf($message, @args),
    );
}

=head2 getobjectlogs($otype, $name)

Return logs for object type C<$otype> having C<$name>.

=cut 

sub getobjectlogs {
    my ($self, $otype, $name) = @_;

    my $sth = $self->db->prepare(q{
        select ikey from objectslogs where
            otype = ? and
            name  = ?
        group by ikey
    });
    $sth->execute($otype, $name);
    my @ids;
    while (my $res = $sth->fetchrow_hashref) {
        push(@ids, $res->{ikey});
    }
    @ids or return;

    my $sth2 = $self->db->prepare(sprintf(
        q{
            select * from objectslogs where ikey IN (%s)
            order by logdate asc
        },
        join(',', ('?') x scalar(@ids))
    ));

    $sth2->execute(@ids);
    my @logs;
    while (my $res = $sth2->fetchrow_hashref) {
        push(@logs, $res);
    }

    return @logs;
}

=head2 getlogs

Return logs for last year

=cut

sub getlogs {
    my ($self) = @_;
    my $sth2 = $self->db->prepare(
        q{
            select * from objectslogs 
            where logdate > now() - '1 year'::interval 
            order by logdate asc
        },
    );

    $sth2->execute();
    my @logs;
    while (my $res = $sth2->fetchrow_hashref) {
        push(@logs, $res);
    }

    return @logs;
}


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