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

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 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 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 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);
}

sub attribute {
    my ($self, $attribute) = @_;
    return LATMOS::Accounts::Bases::Attributes->new(
        $attribute,
        $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);
}

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; 
}

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

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

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;
        };
        $res += ($attribute->set($cdata{$cfield}) || 0);

    }
    $res
}

=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')) {
        return $self->_set_password($clear_pass);
    } 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");
    }
}

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

    return fascist_check($password, $dictionary);
}

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;
}


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);
}

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;
    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;
    }
    $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 text_dump {
    my ($self, $handle, $options, $base) = @_;
    print $handle $self->dump($options, $base);
    return 1;
}

sub dump {
    my ($self, $options, $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,
        $options->{only_rw} ? 'rw' : 'r')) {
        my $oattr = $base->attribute($otype, $attr);
        if (ref $self) {
            my $val = $self->get_c_field($attr);
            if ($val || $options->{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;
}

1;

__END__

=head1 CANICALS FIELDS

=head2 User class

=head2 Group class

=head1 SEE ALSO

Mention other useful documentation such as the documentation of
related modules or operating system documentation (such as man pages
in UNIX), or any relevant external documentation such as RFCs or
standards.

If you have a mailing list set up for your module, mention it here.

If you have a web site set up for your module, mention it here.

=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