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

package LATMOS::Accounts::Bases::Objects;

use 5.010000;
use strict;
use warnings;
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Bases::Attributes;
use Crypt::Cracklib;

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

=head1 NAME

LATMOS::Accounts::Bases::Objects - Base class for account objects

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases::Objects;
  LATMOS::Accounts::Bases::Objects->new($base, $type, $id);

=head1 DESCRIPTION

=head1 FUNCTIONS

=cut

=head2 is_supported

If exists, must return true or false if the object is supported or not

=cut

=head2 list($base)

List object supported by this module existing in base $base

Must be provide by object class

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

=cut

=head2 list_from_rev($base, $rev)

List objects create or modified after base revision C<$rev>.

=cut

=head2 new($base, $id)

Create a new object having $id as uid.

=cut

sub new {
    my ($class, $base, $id, @args) = @_;
    # So can be call as $class->SUPER::new()
    bless {
        _base => $base,
        _type => lc(($class =~ m/::([^:]*)$/)[0]),
        _id => $id,
    }, $class;
}

# _new($base, $type, $id, ...)

# Return a new object of type $type having unique identifier
# $id, all remaining arguments are passed to the subclass.

sub _new {
    my ($class, $base, $otype, $id, @args) = @_;

    # finding perl class:
    my $pclass = $base->_load_obj_class($otype) or return;
    my $newobj = "$pclass"->new($base, $id, @args) or return;
    $newobj->{_base} = $base;
    $newobj->{_type} = lc($otype);
    $newobj->{_id} ||= $id;
    return $newobj;
}

=head2 _create($class, $base, $id, %data)

Must create a new object in database.

Is called if underling base does not override create_object

    sub _create(
        my ($class, $base, $id, %data)
    }

=cut

=head2 type

Return the type of the object

=cut

sub type {
    my ($self) = @_;
    if (ref $self) {
        return $self->{_type}
    } else {
        return lc(($self =~ /::([^:]+)$/)[0]);
    }
}

=head2 base

Return the base handle for this object.

=cut

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

=head2 id

Must return the unique identifier for this object

=cut

sub id {
    my ($self) = @_;
    $self->{_id}
}


=head2 Iid

Return internal id if different from Id

=cut

sub Iid {
    my ($self) = @_;
    $self->id
}

=head2 list_canonical_fields($for)

Object shortcut to get the list of field supported by the object.

=cut

sub list_canonical_fields {
    my ($self, $for) = @_;
    $for ||= 'rw';
    $self->_canonical_fields($for);
}

=head2 attribute ($attribute)

Return L<LATMOS::Accounts::Bases::Attributes> object for C<$attribute>

=cut

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

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

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

sub _canonical_fields {
    my ($class, $base, $for) = @_;
    $for ||= 'rw';
    my $info = $base->_get_attr_schema($class->type);
    my @attrs = map { $base->attribute($class->type, $_) } keys %{$info || {}};
    @attrs = grep { ! $_->ro } @attrs if($for =~ /w/);
    @attrs = grep { $_->readable } @attrs if($for =~ /r/);
    map { $_->name } grep { !$_->hidden }  @attrs;
}

=head2 get_field($field)

Return the value for $field, must be provide by data base.

    sub get_field {
        my ($self, $field)
    }

=cut

=head2 get_c_field($cfield)

Return the value for canonical field $cfield.

Call driver specific get_field()

=cut

sub get_c_field {
    my ($self, $cfield) = @_;
    $self->base->check_acl($self, $cfield, 'r') or do {
        $self->base->log(LA_ERR, "Permission denied to get %s/%s",
            $self->id, $cfield
        );
        return;
    };
    return $self->_get_c_field($cfield);
}

=head2 get_attributes($attr)

Like get_c_field but always return an array

=cut

sub get_attributes {
    my ($self, $cfield) = @_;
    my $res = $self->get_c_field($cfield);
    return ref $res ? @{ $res } : ($res);
}

sub _get_attributes {
    my ($self, $cfield) = @_;
    my $res = $self->_get_c_field($cfield);
    return ref $res ? @{ $res } : ($res);
}

=head2 get_state ($state)

Return an on fly computed value

=cut

sub get_state {
    my ($self, $state) = @_;
    # hum...
    if (defined(my $res = $self->_get_state($state))) {
        return $res;
    }
    for ($state) {
    }
    return;
}

sub _get_state {
    my ($self, $state) = @_;
    return;
}

sub _get_c_field {
    my ($self, $cfield) = @_;
    my $attribute = $self->attribute($cfield) or do {
        $self->base->log(LA_WARN, "Unknow attribute $cfield");
        return;
    };
    $attribute->readable or do {
        $self->base->log(LA_WARN, "Attribute $cfield is not readable");
        return;
    };
    return $attribute->get; 
}

=head2 queryformat ($fmt)

Return formated string according C<$fmt>

=cut

sub queryformat {
    my ($self, $fmt) = @_;
    $fmt =~ s/\\n/\n/g;
    $fmt =~ s!
        (?:%{([^:}]*)(?::([^}]+))?})
        !
        my $val = $self->get_c_field($1);
        sprintf('%' . ($2 || 's'), ref $val ? join(',', @$val) : ($val||''))
        !egx;
    $fmt;
}

=head2 set_fields(%data)

Set values for this object. %data is a list or peer field => values.

    sub set_fields {
        my ($self, %data) = @_;
    }

=cut

=head2 check_allowed_values ($attr, $values)

Check if value C<$values> is allowed for attributes C<$attr>

=cut

sub check_allowed_values {
    my ($self, $attr, $values) = @_;
    $self->base->check_allowed_values($self->type, $attr, $values);
}

=head2 attr_allow_values ($attr)

Return allowed for attribute C<$attr>

=cut

sub attr_allow_values {
    my ($self, $attr) = @_;
    return $self->base->obj_attr_allowed_values(
        $self->type,
        $attr,
    );
}

=head2 set_c_fields(%data)

Set values for this object. %data is a list or peer 
canonical field => values. Fields names are translated.

=cut

sub set_c_fields {
    my ($self, %cdata) = @_;
    foreach my $cfield (keys %cdata) {
        $self->base->check_acl($self, $cfield, 'w') or do { 
            $self->base->log(LA_ERR, "Cannot modified %s/%s: %s",
                $self->type, $self->id, "permission denied");
            return;
        };
    }

    foreach my $cfield (keys %cdata) {
        $self->check_allowed_values($cfield, $cdata{$cfield}) or do {
            $self->base->log(LA_ERR, "Cannot modified %s/%s: %s",
                $self->type, $self->id, "non authorized value");
            return;
        };
    }
    $self->_set_c_fields(%cdata);
}

sub _set_c_fields {
    my ($self, %cdata) = @_;
    my %data;
    my $res = 0;
    foreach my $cfield (keys %cdata) {
        my $attribute = $self->attribute($cfield) or do {
            $self->base->log(LA_ERR,
                "Cannot set unsupported attribute %s to %s (%s)",
                $cfield, $self->id, $self->type
            );
            return;
        };
        $attribute->ro and do {
            $self->base->log(LA_ERR,
                "Cannot set read-only attribute %s to %s (%s)",
                $cfield, $self->id, $self->type
            );
            return;
        };
        $attribute->mandatory &&
            (!(defined($cdata{$cfield})) || $cdata{$cfield} eq '') and do {
            $self->base->log(LA_ERR,
                "%s attribute cannot be empty, ignoring for object %s/%s",
                $cfield,
                        $self->type,
                        $self->id,
            );
            return 0;
        };
    }

    my %updated = ();
    foreach my $cfield (keys %cdata) {
        my $attribute = $self->attribute($cfield) or do {
            $self->base->log(LA_ERR,
                "Cannot set unsupported attribute %s to %s (%s)",
                $cfield, $self->id, $self->type
            );
            return;
        };
        if ($attribute->set($cdata{$cfield})) {
            $updated{$cfield} = $attribute->{notify};
        }
    }
    
    if (keys %updated) {
        $self->ReportChange('Update', 'Attributes %s where updated', join(', ', sort keys %updated));
        foreach (sort keys %updated) {
            $self->ReportChange('Attributes', '%s set to %s', $_, 
                (ref $cdata{$_}
                    ? join(', ', @{ $cdata{$_} })
                    : $cdata{$_}) || '(none)')
                if ($updated{$_});
        }
    }
    return scalar(keys %updated);
}

=head2 set_password($password)

Set the password into the database, $password is the clear version
of the password.

This function store it into userPassword canonical field if supported
using crypt unix and md5 algorythm (crypt md5), the salt is 8 random
caracters.

The base driver should override it if another encryption is need.

=cut

sub set_password {
    my ($self, $clear_pass) = @_;
    if ($self->base->check_acl($self, 'userPassword', 'w')) {
        if ($self->_set_password($clear_pass)) {
             $self->ReportChange('Password', 'user password has changed');
             return 1;
        } else {
            return;
        }
    } else {
        $self->base->log(LA_ERROR, "Permission denied for %s to change its password",
            $self->id);
        return;
    }
}

sub _set_password {
    my ($self, $clear_pass) = @_;
    if (my $attribute = $self->base->attribute($self->type, 'userPassword')) {
        my @salt_char = (('a' .. 'z'), ('A' .. 'Z'), (0 .. 9), '/', '.');
        my $salt = join('', map { $salt_char[rand(scalar(@salt_char))] } (1 .. 8));
        my $res = $self->set_fields($attribute->iname, crypt($clear_pass, '$1$' . $salt));
        $self->base->log(LA_NOTICE, 'Mot de passe changé pour %s', $self->id)
            if($res);
        return $res;
    } else {
        $self->log(LA_WARN,
            "Cannot set password: userPassword attributes is unsupported");
    }
}

=head2 check_password ($password)

Check given password is secure using L<Crypt::Cracklib>

=cut

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

    if ($password !~ /^[[:ascii:]]*$/) {
       return "the password must contains ascii characters only";
    }

    return fascist_check($password, $dictionary);
}

=head2 search ($base, @filter)

Search object matching C<@filter>

=cut

sub search {
    my ($class, $base, @filter) = @_;
    my @results;
    my %parsed_filter;
    while (my $item = shift(@filter)) {
        # attr=foo => no extra white space !
        # \W is false, it is possible to have two char
        my ($attr, $mode, $val) = $item =~ /^(\w+)(?:(\W)(.+))?$/ or next;
        if (!$mode) {
            $mode = '~';
            $val = shift(@filter);
        }
        push(
            @{$parsed_filter{$attr}},
            {
                attr => $attr,
                mode => $mode,
                val  => $val,
            }
        );
    }
    foreach my $id ($base->list_objects($class->type)) {
        my $obj = $base->get_object($class->type, $id);
        my $match = 1;
        foreach my $field (keys %parsed_filter) {
            $base->attribute($class->type, $field) or
                la_log LA_WARN "Unsupported attribute $field";
            my $tmatch = 0;
            foreach (@{$parsed_filter{$field}}) {
                my $value = $_->{val};
                my $fval = $obj->_get_c_field($field) || '';
                if ($value eq '*') {
                    if ($fval ne '') {
                        $tmatch = 1;
                        last;
                    }
                } elsif ($value eq '!') {
                    if ($fval eq '') {
                        $match = 1;
                        last;
                    }
                } elsif ($_->{mode} eq '=') {
                    if ($fval eq $value) {
                        $tmatch = 1;
                        last;
                    }
                } elsif($_->{mode} eq '~') {
                    if ($fval =~ m/\Q$value\E/i) {
                        $tmatch = 1;
                        last;
                    }
                }
            }
            $match = 0 unless($tmatch);
        }
        push(@results, $id) if($match);
    }
    @results;
}

=head2 attributes_summary ($base, $attribute)

Return list of values existing in base for C<$attribute>

=cut

sub attributes_summary {
    my ($class, $base, $attribute) = @_;
    my %values;
    foreach my $id ($base->list_objects($class->type)) {
        my $obj = $base->get_object($class->type, $id);
        my $value = $obj->_get_c_field($attribute);
        if ($value) {
            if (ref $value) {
                foreach (@$value) {
                    $values{$_} = 1;
                }
            } else {
                $values{$value} = 1;
            }
        }
    }
    return sort(keys %values);
}

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

Find next free uniq id for attribute C<$field>

=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 ($base->list_objects($class->type)) {
            my $obj = $base->get_object($class->type, $_) or next;
            my $id = $obj->_get_c_field($field) or next;
            $existsid{$id + 0} = 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;
}

=head2 text_dump ($handle, $config, $base)

Dump object into C<$handle>

=cut

sub text_dump {
    my ($self, $handle, $config, $base) = @_;
    print $handle $self->dump($config, $base);
    return 1;
}

=head2 dump

Return dump for tihs object

=cut

sub dump {
    my ($self, $config, $base) = @_;

    my $otype = $self->type;
    $base ||= $self->base;
    my $dump;
    if (ref $self) {
        $dump .= sprintf "# base %s: object %s/%s\n",
            $base->label, $self->type, $self->id;
    }
    $dump .= sprintf "# %s\n", scalar(localtime);

    foreach my $attr (sort { $a cmp $b } $base->list_canonical_fields($otype,
        $config->{only_rw} ? 'rw' : 'r')) {
        my $oattr = ref $self ? $self->attribute($attr) : $base->attribute($otype, $attr);
        if (ref $self) {
            my $val = $self->get_c_field($attr);
            if ($val || $config->{empty_attr}) {
                if (my @allowed = $base->obj_attr_allowed_values($otype, $attr)) {
                    $dump .= sprintf("# %s must be%s: %s\n",
                        $attr,
                        ($oattr->mandatory ? '' : ' empty or either'),
                        join(', ', @allowed)
                    );
                }
                my @vals = ref $val ? @{ $val } : $val;
                foreach (@vals) {
                    $_ ||= '';
                    s/\r?\n/\\n/g;
                    $dump .= sprintf("%s%s:%s\n", 
                        $oattr->ro ? '# (ro) ' : '',
                        $attr, $_ ? " $_" : '');
                }
            }
        } else {
            if (my @allowed = $base->obj_attr_allowed_values($otype, $attr)) {
                $dump .= sprintf("# %s must be empty or either: %s\n",
                    $attr,
                    join(', ', @allowed)
                );
            }
            $dump .= sprintf("%s%s: %s\n", 
                $oattr->ro ? '# (ro) ' : '',
                $attr, '');
        }
    }
    return $dump;
}

=head2 ReportChange($changetype, $message, @args)

Possible per database way to log changes

=cut

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

    $self->base->ReportChange(
        $self->type,
        $self->id,
        $self->Iid,
        $changetype, $message, @args
    )
}

1;

__END__


=head1 SEE ALSO

L<LATMOS::Accounts::Bases>

=head1 AUTHOR

Thauvin Olivier, E<lt>olivier.thauvin.ipsl.fr@localdomainE<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