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

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

use 5.010000;
use strict;
use warnings;

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 => ($class =~ m/[^:]*$/)[0],
    }, $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) = @_;
    $self->base->list_canonical_fields($self->type, $for);
}

=head2 get_field_name($field, $for)

Object shortcut to get the field name supported by the object.

=cut

sub get_field_name {
    my ($self, $field, $for) = @_;
    $self->base->get_field_name($self->type, $field, $for);
}

=head2 _canonical_fields

Must return the list of field supported by the object.

Notice this query will always come from the upstream data base,
this function is just a facility to store data in the module, but the
underling database can reply themself.

Is call if underling base doesn't override list_canonical_fields()

See list_canonical_fields().

    sub _canonical_fields { 
        my ($self) = @_;
    }

=cut

sub _delayed_fields {
    my ($self)= @_;
    return ();
}

=head2 _get_fields_name($field, $for)

Return the fields name for canonical field $field.
$for, if set, is a string containing 'r' for read, 'w' for write,
depending usage context.

    sub _get_field_name {
        my ($self, $field, $for) = @_;
    }

=cut

=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_fields($cfield)

Return the value for canonical field $cfield.

Call driver specific get_field_name() and get_field()

=cut

sub get_c_field {
    my ($self, $cfield) = @_;
    my $field = $self->base->get_field_name($self->type, $cfield, 'r') or return;
    $self->get_field($field);
}

=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 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) = @_;
    my %data;
    foreach my $cfield (keys %cdata) {
        my $field = $self->base->get_field_name($self->type, $cfield) or next;
        $data{$field} = $cdata{$cfield};
    }
    keys %data or return 1; # TODO: return an error ?
    $self->set_fields(%data);
}

=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 (my $field = $self->base->get_field_name($self->type, 'userPassword')) {
        my @salt_char = (('a' .. 'z'), ('A' .. 'Z'), (0 .. 9), '/', '.');
        my $salt = join('', map { $salt_char[rand(scalar(@salt_char))] } (1 .. 8));
        $self->set_fields($field, crypt($clear_pass, '$1$' . $salt));
    }
}

sub search {
    my ($class, $base, %filter) = @_;
    my @results;
    foreach my $id ($base->list_objects($class->type)) {
        my $obj = $base->get_object($class->type, $id);
        my $match = 1;
        foreach my $field (keys %filter) {
            my $value = $filter{$field};
            $base->get_field_name($class->type, $field, 'r') or next;
            my $fval = $obj->get_c_field($field) || '';
            if ($value eq '*') {
                if ($fval eq '') {
                    $match = 0;
                    last;
                }
            } elsif ($fval !~ m/\Q$value\E/i) {
                $match = 0;
                last;
            }
        }
        push(@results, $id) if($match);
    }
    @results;
}

sub find_next_numeric_id {
    my ($class, $base, $field, $min, $max) = @_;
    $base->get_field_name($class->type, $field) or return;
    $min ||= 
        $field eq 'uidNumber' ? 500 :
        $field eq 'gidNumber' ? 500 :
        1;
    $max ||= 65635;
    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} = 1;
    }
    for(my $i = $min; $i <= $max; $i++) {
        $existsid{$i} or return $i;
    }
    return;
}

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