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

package LATMOS::Accounts::Bases;

use 5.010000;
use strict;
use warnings;
use LATMOS::Accounts::Bases::Objects;
use LATMOS::Accounts::Bases::Attributes;
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Utils qw( exec_command to_ascii );
use DateTime;

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

=head1 NAME

LATMOS::Accounts::Bases - Base class for account data bases

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases;
  my $base = LATMOS::Accounts::Bases->new('type', %options);
  ...

=head1 DESCRIPTION

This module provide basic functions for various account base

=head1 FUNCTIONS

=cut

=head2 new($type, %options)

Return, if success, a new data base account object, $type is
account base type, %options to setup the base.

=cut

sub new {
    my ($class, $type, $options) = @_;

    my $pclass = ucfirst(lc($type));
    eval "require LATMOS::Accounts::Bases::$pclass;";
    if ($@) {
        la_log(LA_DEBUG, "Failed to load base type `%s': %s", $type, $@);
        return
    }
    my $base = "LATMOS::Accounts::Bases::$pclass"->new(%{$options->{params}})
        or return;
    $base->{_type} = lc($pclass);
    $base->{_label} = $options->{label};
    $base->{_options} = $options->{params};
    $base->{wexported} = 0;
    $base->{defattr} = $options->{defattr};
    $base->{_acls} = $options->{acls};
    $base->{_allowed_values} = $options->{allowed_values};
    $base->{_la} = $options->{la};
    la_log(LA_DEBUG, 'Instanciate base %s (%s)', ($base->label || 'N/A'), $pclass);
    $base
}

=head2 load

Make account base loading data into memory if need.
Should always be called, if database fetch data on the fly
(SQL, LDAP), the function just return True.

=cut

# override by the database driver if need
sub load { 1 }

=head2 label

Return the database label

=cut

sub label {
    $_[0]->{_label} || 'NoLabel';
}

=head2 type

Return the type of the base

=cut

sub type {
    $_[0]->{_type};
}

=head2 la

return LATMOS::Accounts object parent to the base

=cut

sub la { $_[0]->{_la} };

=head2 config ($opt)

Return options from config

=cut

sub config {
    my ($self, $opt, $default) = @_;
    return defined($self->{_options}{$opt}) ? $self->{_options}{$opt} : $default;
}

=head2 wexported

See L</unexported>

=cut

sub wexported { unexported(@_) }

=head2 unexported ($wexported)

Set base to report unexported object or not

=cut

sub unexported {
    my ($self, $wexported) = @_;
    my $old = $self->{wexported};
    if (defined($wexported)) {
        $self->{wexported} = $wexported;
        $self->log(LA_DEBUG, "Switching exported mode: %s => %s", $old,
            $wexported);
    }
    return($old || 0);
}

=head2 temp_switch_unexported($CODE, $value)

Switch the base to unexported mode given by C<$value>, run C<$CODE>, restore
back the previous state and return the result of code ref.

=cut

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

    my $old = $self->unexported($value || 0);
    my $res = $sub->();
    $self->unexported($old);
    return $res;
}

=head2 log($level, $msg, $arg)

Log a message prefixed by database information

=cut

sub log {
    my ($self, $level, $msg, @args) = @_;
    my $prefix = 'Base(' . $self->type . '/' . $self->label . ')';
    LATMOS::Accounts::Log::la_log($level, "$prefix $msg", @args);
}

=head2 ReportChange($otype, $name, $ref, $changetype, $message, @args)

Functions to report back

=cut 

sub ReportChange {}

=head2 list_supported_objects(@otype)

Return a list of supported object

@type is an additionnal list of objects to check

=cut

sub list_supported_objects {
    my ($self, @otype) = @_;
    my %res;
    foreach my $inc (@INC) {
        my $sub = 'LATMOS::Accounts::Bases::' . ucfirst($self->type);
        $sub =~ s/::/\//g;
        foreach (glob("$inc/$sub/[A-Z]*.pm")) {
            s/.*\///;
            s/\.pm$//;
            $res{lc($_)} = 1;
        }
    }
    $res{$_} = 1 foreach(@otype);
    my @sobj = grep { $self->is_supported_object($_) } keys %res;
    la_log(LA_DEBUG, "Base %s supported objects: %s", $self->type, join(', ', @sobj));
    return @sobj;
}

=head2 ListSubObjectOType($otype)

Return a list of sub object type supported by C<otype> objects.

=cut

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

    # finding perl class:
    my $pclass = $self->_load_obj_class($otype) or return;
    my $definition = "$pclass"->GetOtypeDef($self) or return;

    return keys %{ $definition || {} }
}

=head2 GetSubObjectKey($otype, $sotype)

Return the key linking sub object C<$sotype> to object type C<$otype>

=cut

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

    # finding perl class:
    my $pclass = $self->_load_obj_class($otype) or return;
    my $definition = "$pclass"->GetOtypeDef($self, $sotype) or return;

    return $definition->{$sotype};
}


=head2 ordered_objects

Return supported object type ordered in best order for synchronisation

=cut

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

    my %deps;
    my %maxdeps;
    my @objs = sort { $b cmp $a } $self->list_supported_objects;
    foreach my $obj (@objs) {
        foreach my $at ($self->list_canonical_fields($obj)) {
            my $attr = $self->attribute($obj, $at);
            $attr->ro and next;
            $attr->{delayed} and next;
            if (my $res = $attr->reference) {
                $deps{$obj}{$res} ||= 1;
                if ($attr->mandatory) {
                    $deps{$obj}{$res} = 2;
                    $maxdeps{$res} = 1;
                }
            }
        }
    }

    sort {
        if (keys %{$deps{$a} || {}}) {
            if (keys %{$deps{$b} || {}}) {
                return (
                    ($deps{$a}{$b} || 0) > ($deps{$b}{$a} || 0) ?  1 :
                    ($deps{$b}{$a} || 0) > ($deps{$a}{$b} || 0) ? -1 :
                    ($maxdeps{$b} || 0) - ($maxdeps{$a} || 0)
                );
            } else {
                return 1;
            }
        } elsif (keys %{$deps{$b} || {}}) {
            return -1;
        } else {
            return  ($maxdeps{$b} || 0) - ($maxdeps{$a} || 0)
        }
    } @objs;
}

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

    $otype or die "No type given: " . join(', ', caller) . "\n";
    # finding perl class:
    my $pclass = ref $self;
    $pclass .= '::' . ucfirst(lc($otype));
    eval "require $pclass;";
    if ($@) {
        $self->log(LA_DEBUG, 'Cannot load perl class %s', $pclass);
        return
    } # error message ?
    return $pclass;
}


=head2 is_supported_object($otype)

Return true is object type $otype is supported

=cut

sub is_supported_object {
    my ($self, $otype) = @_;
    
    if (my $pclass = $self->_load_obj_class($otype)) {
        if ($pclass->can('is_supported')) {
            return $pclass->is_supported($self);
        } else {
            return 1;
        }
    } else {
        return 0;
    }
}

=head2 list_objects($otype, %options)

Return the list of UID for object of $otype.

=cut

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

=head2 listRealObjects

Return the list of UID for object of $otype, alias objects are not return

Options depend of database support

=cut

sub listRealObjects {
    my ($self, $otype) = @_;
    $self->list_objects($otype);
}

=head2 get_object($type, $id)

Return an object of $type (typically user or group) having identifier
$id.

=cut

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

    # finding perl class:
    my $pclass = $self->_load_obj_class($otype) or return;
    my $newobj = "$pclass"->new($self, $id);

    defined($newobj) or do {
        $self->log(LA_DEBUG, "$pclass->new() returned undef for $otype / %s", $id || '(none)');
        return;
    };

    $newobj->{_base} = $self;
    $newobj->{_type} = lc($otype);
    $newobj->{_id} ||= $id;

    return $newobj;
}

=head2 create_c_object($type, $id, %data)

Create and return an object of type $type with unique id
$id having %data using canonical fields

=cut

sub create_c_object {
    my ($self, $otype, $id, %cdata) = @_;
    $self->check_acl($otype, '@CREATE', 'w') or do {
        $self->log(LA_WARN, 'permission denied to create object type %s',
            $otype);
        return;
    };

    $self->_create_c_object($otype, $id, %cdata);
}

sub _create_c_object {
    my ($self, $otype, $id, %cdata) = @_;

    $id ||= ''; # Avoid undef

    if (my $chk = (
        lc($otype) eq 'user' || lc($otype) eq 'group')
        ? LATMOS::Accounts::Utils::check_ug_validity($id)
        : LATMOS::Accounts::Utils::check_oid_validity($id)) {
        $self->log(LA_ERR, "Cannot create $otype with ID $id `%s:'", $chk);
        return;
    }
    foreach my $cfield (keys %cdata) {
        $self->check_allowed_values($otype, $cfield, $cdata{$cfield}) or do {
            my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR);
            $self->log(LA_ERR, "Cannot create $otype, wrong value%s", ($last ? ": $last" : ''));
            return;
        };
    }

    # populating default value
    {
        my %default = $self->compute_default($otype, $id, %cdata);
        foreach my $k (keys %default) {
            $cdata{$k} = $default{$k} unless(exists($cdata{$k}));
        }
    }

    my %data;
    my $sub;
    foreach my $cfield (keys %cdata) {
        # Parsing subobject creation:

        if (my ($sotype, $key, $scfield) = $cfield =~ /^(\w+)(?:\[(\w+)\])?\.(.*)/) {
            $key ||= '_';
            $sub->{$sotype}{$key}{$scfield} = $cdata{$cfield};
        } else {
            my $attribute = $self->attribute($otype, $cfield) or next;
            $attribute->ro and next;
            $data{$cfield} = $cdata{$cfield};
        }
    }

    $self->create_object($otype, $id, %data) or return;
    my $obj = $self->get_object($otype, $id) or return;
    $obj->ReportChange('Create', 'Object created with %s', join(', ', sort keys %cdata));

    foreach my $attrname (keys %data) {
        my $attribute = $self->attribute($obj->type, $attrname) or next;
        $attribute->monitored or next;

        $obj->ReportChange('Attributes', '%s set to %s', $attrname,
            (ref $data{$attrname}
                ? join(', ', @{ $data{$attrname} })
                : $data{$attrname}) || '(none)');
    }

    if ($sub) {

        # Security: if caller is create_c_object calling it to check permission ?
        # See below
        # my ($caller) = caller();
        # my $subcreate = $caller eq 'create_c_object' ? 'create_c_object' : __SUB__;
        
        # Trying to create subobject
        foreach my $sotype (keys %$sub) {
            my $SubKeyRef = $self->GetSubObjectKey($otype, $sotype) or do {
                $self->log(LA_ERR, "Cannot create object type $sotype, subtype of $otype not defined");
                return;
            };
            foreach my $skey (keys %{ $sub->{$sotype} || {} }) {
                # Building id
                my $info = $sub->{$sotype}{$skey} || {};
                # For id: if key is given using it, otherwise using random
                my $sid = 
                    $info->{$SubKeyRef} ||
                    $id . '-' . join('', map { ('a' .. 'z')[rand(26)] } (0 .. 6));
                $info->{$SubKeyRef} = $id;

                # Here we don't check permission to create sub object:
                $self->_create_c_object($sotype, $sid, %{ $info || {} }) or return;
            }
        }
    }

    $obj
}

=head2 create_object($type, $id, %data)

Create and return an object of type $type with unique id
$id having %data.

This method should be provided by the data base handler.

=cut

sub create_object {
    my ($self, $otype, $id, %data) = @_;

    "$id" or do {
        $self->log(LA_ERR, l("Cannot create %s object with empty id"),
            $otype);
        return;
    };
    my $pclass = $self->_load_obj_class($otype) or do {
        $self->log(LA_ERR, "Cannot create %s object type (cannot load class)",
            $otype);
        return;
    };

    if (!$pclass->checkValues($self, $id, %data)) {
        my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR);
        la_log(LA_ERR,
            'Cannot create %s (%s) in base %s (%s): wrong value%s',
            $id, $otype, $self->label, $self->type,
            ($last ? ": $last" : ''),
        );
        return;
    }

    if ($pclass->_create($self, $id, %data)) {
        la_log(LA_INFO,
            'Object %s (%s) created in base %s (%s)',
            $id, $otype, $self->label, $self->type,
        );
    } else {
        my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR);
        la_log(LA_ERR,
            'Object creation %s (%s) in base %s (%s) failed%s',
            $id, $otype, $self->label, $self->type,
            ($last ? ": $last" : ''),
        );
        return;
    };

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

=head2 defaultAttributeValue($otype, $attr)

Return default static value for attribute C<$attr>

=cut

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

    my %def = %{ $self->{defattr} || {}};
    return $def{"$otype.$attr"} || '';
}

=head2 compute_default($otype, $id, %cdata)

Return a hash containing value to set for new object

=cut

sub compute_default {
    my ($self, $otype, $id, %cdata) = @_;

    my %default;
    foreach my $def (keys %{ $self->{defattr} || {}}) {
        if ($def =~ /^$otype\.(.*)$/) {
            $default{$1} = $self->{defattr}{$def} if(!$cdata{$1});
        }
    }

    # computed default value (not a simple set)
    if (lc($otype) eq 'user') {
        if (!$cdata{homeDirectory}) {
            $default{homeDirectory} = $self->{defattr}{'user.homebase'}
                ? $self->{defattr}{'user.homebase'} . "/$id" 
                : '';
        }

        if (!$cdata{uidNumber}) {
            $default{uidNumber} ||= $self->find_next_numeric_id('user', 'uidNumber',
            $self->{defattr}{'user.min_uid'}, $self->{defattr}{'user.max_uid'});
        }

        my $mailid = $cdata{givenName} && $cdata{sn}
            ? sprintf('%s.%s',
                to_ascii(lc($cdata{givenName})),
                to_ascii(lc($cdata{sn})),)
            : undef;
        $mailid =~ s/\s+/-/g if($mailid);

        if ($mailid &&
            $self->is_supported_object('aliases') &&
            ! $self->get_object('aliases', $mailid)) {
            if (my $attr = $self->attribute($otype, 'mail')) {
                if ((!$attr->ro) && $self->{defattr}{'user.maildomain'}) {
                    $default{mail} ||= sprintf('%s@%s',
                    $mailid,
                    $self->{defattr}{'user.maildomain'});
                }
            }
            if (my $attr = $self->attribute($otype, 'aliases')) {
                $default{aliases} ||= $mailid unless ($attr->ro);
            }
            if (my $attr = $self->attribute($otype, 'revaliases')) {
                $default{revaliases} ||= $mailid unless ($attr->ro);
            }
        }
    } elsif (lc($otype) eq 'group') {
        if (!$cdata{gidNumber}) {
            $default{gidNumber} ||= $self->find_next_numeric_id(
                'group', 'gidNumber',
                $self->{defattr}{'group.min_gid'},
                $self->{defattr}{'group.max_gid'}
            );
        }
    }

    return %default;
}

sub _allowed_values {
    $_[0]->{_allowed_values}
}

=head2 obj_attr_allowed_values ($otype, $attr)

Return value allowed for this attribute

=cut

sub obj_attr_allowed_values {
    my ($self, $otype, $attr) = @_;
    if ($self->_allowed_values &&
        $self->_allowed_values->SectionExists("$otype.$attr")) {
        return grep { defined($_) } $self->_allowed_values->val("$otype.$attr", 'allowed');
    }
    return();
}

=head2 check_allowed_values ($otype, $attr, $attrvalues)

Check attributes C<$attr> of object type C<$otype> allow values C<$attrvalues>

=cut

sub check_allowed_values {
    my ($self, $otype, $attr, $attrvalues) = @_;
    $self->_allowed_values or return 1;
    my @values = ref $attrvalues ? @{ $attrvalues } : $attrvalues;
    foreach my $value (@values) {
        $value or next;
        if (my @allowed = $self->obj_attr_allowed_values($otype, $attr)) {
            grep { $value eq $_ } @allowed or do {
                $self->log(LA_ERR,
                    "value `%s' is not allow for %s.%s per configuration (allowed_values)",
                    $value, $otype, $attr
                );
                return;
            };
        }
    }
    return 1;
}

=head2 list_canonical_fields($otype, $for)

Return the list of supported fields by the database for object type $otype.

Optionnal $for specify the goal for which the list is requested, only supported
fields will be returns

=cut

sub list_canonical_fields {
    my ($self, $otype, $for) = @_;
    $for ||= 'rw';
    my $pclass = $self->_load_obj_class($otype) or return;
    sort $pclass->_canonical_fields($self, $for);
}

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

=head2 get_attr_schema

Deprecated

=cut

# TODO: kill this

sub get_attr_schema {
    my ($self, $otype, $attribute) = @_;
    my $info = $self->_get_attr_schema($otype);
    if ($info->{$attribute}) {
        return $info->{$attribute};
    } else {
        return;
    }
}

=head2 attribute($otype, $attribute)

Return attribute object.

See L<LATMOS::Accounts::Bases::Attribute>

=cut

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

    my $attrinfo;
    if (!ref $attribute) {
       $attrinfo = $self->get_attr_schema($otype, $attribute)
            or return;
        $attrinfo->{name} = $attribute;
    } else {
        $attrinfo = $attribute;
    }

    return LATMOS::Accounts::Bases::Attributes->new(
        $attrinfo,
        $self,
        $otype,
    );
}

=head2 delayed_fields

DEPRECATED

=cut 

# TODO: kill this

sub delayed_fields {
    my ($self, $otype, $for) = @_;
    $self->log(LA_WARN, "calling DEPRECATED delayed_fields " . join(',',
            caller));
    $for ||= 'rw';
    my @attrs;
    foreach ($self->list_canonical_fields($otype, $for)) {
        my $attr = $self->attribute($otype, $_) or next;
        $for =~ /w/ && $attr->ro and next;
        $attr->delayed or next;
        push(@attrs, $_);
    }
    @attrs
}

=head2 ochelper ($otype)

Return L<LATMOS::Accounts::Bases::OChelper> object

=cut

sub ochelper {
    my ($self, $otype) = @_;
    my $pclass = ucfirst(lc($otype));
    foreach my $class (
        ref($self) . '::OCHelper::' . $pclass,
        ref($self) . '::OCHelper',
        "LATMOS::Accounts::Bases::OCHelper::$pclass",
        'LATMOS::Accounts::Bases::OCHelper' ) {
        eval "require $class;";
        if ($@) { next } # error message ?
        my $ochelper = "$class"->new($self, $otype);
        return $ochelper;
    }
    return;
}

=head2 delete_object($otype, $id)

Destroy from data base object type $otype having id $id.

=cut

sub delete_object {
    my ($self, $otype, $id) = @_;
    my $obj = $self->get_object($otype, $id) or do {
        $self->log(LA_WARN, 'Cannot delete %s/%s: no such object',
            $otype, $id);
        return;
    };
    $self->check_acl($obj, '@DELETE', 'w') or do {
        $self->log(LA_WARN, 'permission denied to delete %s/%s',
            $otype, $id);
        return;
    };
    my $ref = $obj->Iid;
    if (my $res = $self->_delete_object($otype, $id)) {
        $self->ReportChange($otype, $id, $ref, 'Delete', 'Object deleted');
        return $res;
    }
    return;
}

sub _delete_object {
    my ($self, $otype, $id) = @_;
    my $pclass = $self->_load_obj_class($otype);
    $pclass->_delete($self, $id);
}

=head2 rename_object($otype, $id, $newid)

Rename an object.

=cut

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

    $self->log(LA_DEBUG, "Trying to rename $otype/$id to $newid");
    my $obj = $self->get_object($otype, $id) or do {
        $self->log(LA_WARN, 'Cannot rename %s/%s: no such object',
            $otype, $id);
        return;
    };
    if (my $chk = (lc($otype) eq 'user' || lc($otype) eq 'group')
        ? LATMOS::Accounts::Utils::check_ug_validity($newid)
        : LATMOS::Accounts::Utils::check_oid_validity($newid)) {
        $self->log(LA_ERR, "Cannot rename $otype/$id to ID $newid `%s:'", $chk);
        return;
    }
    $self->check_acl($obj, '@DELETE', 'w') &&
    $self->check_acl($obj, '@CREATE', 'w') or do {
        $self->log(LA_WARN, 'permission denied to rename %s/%s',
            $otype, $id);
        return;
    };

    my $oldref = $obj->Iid;

    if (my $res = $self->_rename_object($otype, $id, $newid)) {
        my $newobj = $self->get_object($otype, $newid) or do {
            $self->log(LA_WARN, 'Cannot get object %s/%s: rename failed ?',
                $otype, $id);
            return;
        };

        $self->ReportChange($otype, $id, $oldref, 'Rename', 'Object rename to %s', $newid);
        $newobj->ReportChange('Rename', 'Object renamed from %s', $id);
        return $res;
    }
    return;
}

sub _rename_object {
    my ($self, $otype, $id, $newid) = @_;
    my $pclass = $self->_load_obj_class($otype);
    $pclass->can('_rename') or do {
        $self->log(LA_ERR, 'rename object type %s is unsupported', $otype);
        return;
    };
    $pclass->_rename($self, $id, $newid);
}

=head2 is_transactionnal

Return True is the database support commit and rollback

=cut

sub is_transactionnal {
    my ($self) = @_;
    return($self->can('_rollback') && $self->can('_commit'));
}

=head2 commit

Save change into the database if change are not done immediately.
This should always be called as you don't know when change are applied.

Return always true if database does not support any transaction.

The driver should provides a _commit functions to save data.

=cut

sub commit {
    my ($self) = @_;
    if ($self->can('_commit')) {
        la_log(LA_DEBUG, 'Commiting data');
        if (!(my $res = $self->_commit)) {
            la_log(LA_ERR, "Commit error on %s", $_->label);
            return $res;
        }
    }

    $self->postcommit();

    return 1;
}

=head2 postcommit

Run postcommit command

=cut

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

    if ($self->{_options}{postcommit}) {
        exec_command($self->{_options}{postcommit},
            {
                BASE => $self->label,
                BASETYPE => $self->type,
                HOOK_TYPE => 'POST',
                CONFIG => $self->{_options}{configdir},  
            }
        );
    } else {
        return 1;
    }
}

=head2 rollback

If database support transaction, rollback changes. Return false
if database does not support.

If supported, driver should provides a _rollback functions

=cut

sub rollback {
    my ($self) = @_;
    if ($self->can('_rollback')) {
       la_log(LA_DEBUG, 'Rolling back data');
       return $self->_rollback;
   } else {
       return 0;
   }
}

=head2 current_rev

Return the current revision of the database

Must be provide by base driver if incremental synchro is supported

=cut

sub current_rev { return }

=head2 list_objects_from_rev($otype, $rev)

Return the list of UID for object of $otype.

=cut

sub list_objects_from_rev {
    my ($self, $otype, $rev) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    if (defined($rev) && $pclass->can('list_from_rev')) {
        return $pclass->list_from_rev($self, $rev);
    } else {
        # no support, return all objects...
        return $self->list_objects($otype);
    }
}

=head2 sync_object_from($srcbase, $otype, $id, %options)

Sync object type C<$otype> C<$id> from base C<$srcbase> to current base.

C<%options>:

=over 4

=item nodelete

Don't delete object if the object synchronize don't exist in source base

=back

=cut

sub sync_object_from {
    my ($self, $srcbase, $otype, $id, %options) = @_;

    # is the object type supported by both
    foreach ($self, $srcbase) {
        $_->is_supported_object($otype) or return '';
    }
    
    if (my $srcobj = $srcbase->get_object($otype, $id)) {
        return $self->sync_object($srcobj, %options);
    } elsif (!$options{nodelete}) {
        $self->_delete_object($otype, $id) and return 'DELETED';
    }
    return;
}

=head2 sync_object

Synchronise an object into this base

=cut

sub sync_object {
    my ($self, $srcobj, %options) = @_;
    $self->is_supported_object($srcobj->type) or return '';
    my @fields = $options{attrs}
        ? @{ $options{attrs} }
        : $self->list_canonical_fields($srcobj->type, 'w');
    my %data;
    foreach (@fields) {
        # check attribute exists in source:
        my $attr = $srcobj->attribute($_) or next;
        $attr->readable or next;
        if (! $options{onepass}) {
            if ($options{firstpass}) {
                $attr->delayed and next;
            } else {
                $attr->delayed or next;
            }
        }
        $data{$_} = $srcobj->GetAttributeValue($_);
    }
    if (my $dstobj = $self->get_object($srcobj->type, $srcobj->id)) {
        keys %data or return 'SYNCED';
        foreach (keys %data) {
            if (!$dstobj->attribute($_) ||
                $dstobj->attribute($_)->ro) {
                delete($data{$_});
            }
        }
        my $res = $dstobj->_set_c_fields(%data);
        if (defined $res) {
            return $res ? 'SYNCED' : '';
        } else {
            return;
        }
    } elsif(!$options{nocreate}) {
        if ((! $options{firstpass}) && (!$options{onepass})) {
            $self->log(LA_ERR, 'This is not first pass, creation wanted but denied');
            return;
        }
        if (my $res = $self->_create_c_object($srcobj->type, $srcobj->id, %data)) {
            return 'CREATED'
        } else {
            return;
        }
    } else {
        # No error, but creation is denied
        return 'Creation skipped';
    }

    return;
}

=head2 search_objects($otype, @filter)

Search object according @filter. @filter is a list
of field/value which should match.

A default function is provided but each db driver can provide
an optimize version.

=cut

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

=head2 attributes_summary($otype, $attr)

Return couple object id / value for attribute C<$attr> of object type C<$otype>

This method is designed to be faster than fetching object one by one.

=cut

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

=head2 attributes_summary_by_object($otype, $attr)

Return couple object id / value for attribute C<$attr> of object type C<$otype>

This method is designed to be faster than fetching object one by one.

=cut

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

=head2 fetchObjectInfo($otype, $attributes, @filters)

Return an hashref with attribute data for each object matching @filters.

If C<$attributes> can be an array ref to a list of attributes.

=cut

sub fetchObjectInfo {
    my ($self, $otype, $attributes, @filters) = @_;

    my %results = map { $_ => {} }  $self->search_objects($otype, @filters);

    foreach my $attr ( ref $attributes ? @$attributes : $attributes) {
        my %res = $self->attributes_summary_by_object($otype, $attr);
        foreach my $obj (keys %results) {
            $results{$obj}{$attr} = $res{$obj};
        }
    }

    \%results;
}

=head2 find_next_numeric_id($otype, $field, $min, $max)

Return, if possible, next numeric id available (typically unix user UID).

=cut

sub find_next_numeric_id {
    my ($self, $otype, $field, $min, $max) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->find_next_numeric_id($self, $field, $min, $max);
}

=head2 authenticate_user($username, $passwd)

Return true if authentication success.

Must be override by driver if the base have a proper authentication method

=cut

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 user $username");
        return;
    };

    if ($uobj->_get_c_field('expired')) {
        la_log(LA_ERR, "Account $username has expired (%s)",
            $uobj->_get_c_field('expired'));
        return;
    }

    if ($uobj->_get_c_field('locked')) {
        la_log(LA_ERR, "Account $username is currently locked");
        return;
    }

    my $password = $uobj->get_field('userPassword') or do {
        la_log(LA_ERR, "Cannot authenticate user $username having no passwd");
        return;
    };
    if ($password eq crypt($passwd, $password)) { # crypt unix
        la_log(LA_NOTICE, "User $username authenticated");
        return 1;
    } else {
        la_log(LA_ERR, "Cannot authenticate user $username: wrong password");
        return 0;
    }
}

=head2 passCrypt($clear_pass)

Return an encrypted password using method set in config

=cut

sub passCrypt {
    my ($self, $clear_pass) = @_;

    my $method = $self->config('crypt_method');

    LATMOS::Accounts::Utils::Crypt($clear_pass, $method);
}

=head2 connect($username, $password)

Authenticate the user and store the username as connected

=cut

sub connect {
    my ($self, $username, $password) = @_;
    my $auth = $self->authenticate_user($username, $password);
    if ($auth) {
        $self->{_user} = $username;
        la_log(LA_DEBUG, "Connected as $username");
    }
    return $auth;
}

=head2 user

Return the current connected username

=cut

sub user { $_[0]->{_user} }

=head2 check_acl($obj, $attr, $perm)

Return true if connected user have C<$perm> permission on attribute C<$attr> of
object C<$obj>.

=cut

sub check_acl {
    my ($self, $obj, $attr, $perm) = @_;
    if ($self->{_acls}) {
        my ($who, $groups) = ($self->user || '');

        $self->{_acl_cache}{uid} ||= '';

        if ($self->{_acl_cache}{uid} ne $who) {
            $self->{_acl_cache}{uid} = $who;
            my $uo = $self->get_object('user', $who);
            $self->{_acl_cache}{obj} = $uo;
            if ($uo) {
                $self->{_acl_cache}{groups} = [ $uo->_get_attributes('memberOf') ];
            }
        }

        if ($who && (my $uo = $self->{_acl_cache}{obj})) {
            $groups = $self->{_acl_cache}{groups};
        } else {
            $who = '';
        }
        my $res = $self->{_acls}->check($obj, $attr, $perm, $who, $groups);
        $self->log(LA_INFO, 'permission denied for "%s" to get %s.%s for %s',
           $who, ref $obj ? $obj->id . '(' . $obj->type . ')' : $obj, $attr, $perm) if (!$res);
        return $res;
    } else {
        # No acls, woot
        return 1;
    }
}

=head2 text_empty_dump($fh, $otype, $options)

Empty object dump

=cut

sub text_empty_dump {
    my ($self, $fh, $otype, $options) = @_;
    my $pclass = $self->_load_obj_class($otype) or return;
    $pclass->text_dump($fh, $options, $self);
}

=head2 QFunc( $sub, @args )

Compute function given in queryformat/search

=cut

sub QFunc {
    my ($self, $sub, $args) = @_;

    $args ||= '';
    my @args = split(',', $args);

    for ($sub) {
        /^now$/ and return DateTime->now->iso8601;
    }

    return '';
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 by Thauvin Olivier

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