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

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

use 5.010000;
use strict;
use warnings;
use LATMOS::Accounts::Log;

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) = @_;
    $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_field($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 $return;
    eval {
        $self->base->check_acl($self, $cfield, 'r') or die "Permission denied";
        $return = $self->_get_c_field($cfield);
    };
    $return
}

=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_c_field {
    my ($self, $cfield) = @_;
    my $return;
    eval {
        my $field = $self->base->get_field_name($self->type, $cfield, 'r') or
            die "Unknow attribute $cfield";
        $return = $self->get_field($field);
    };
    $return
}

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 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;
    eval {
        foreach my $cfield (keys %cdata) {
            $self->base->check_acl($self, $cfield, 'w') or 
                die "permission denied";
        }
    };
    return if($@);
    $self->_set_c_fields(%cdata);
}

sub _set_c_fields {
    my ($self, %cdata) = @_;
    my %data;
    foreach my $cfield (keys %cdata) {
        my $field = $self->base->get_field_name($self->type, $cfield, 'w') or do {
            $self->base->log(LA_ERR,
                "Cannot set unsupported attribute %s to %s (%s)",
                $cfield, $self->id, $self->type
            );
            return;
        };
        $data{$field} = $cdata{$cfield};
    }
    keys %data or return 0; # 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 ($self->base->check_acl($self, 'userPassword', 'w')) {
        return $self->_set_password($clear_pass);
    } else {
        $self->log(LA_ERROR, "Permission denied for %s to change its password",
            $self->id);
        return;
    }
}

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));
        return $self->set_fields($field, crypt($clear_pass, '$1$' . $salt));
    } else {
        $self->log(LA_WARN,
            "Cannot set password: userPassword attributes is unsupported");
    }
}

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,
                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 (@parsed_filter) {
            my $value = $field->{val};
            $base->get_field_name($class->type, $field->{attr}, 'r') or die
            "Unsupported attribute $field->{attr}\n";
            my $fval = $obj->_get_c_field($field->{attr}) || '';
            if ($value eq '*') {
                if ($fval eq '') {
                    $match = 0;
                    last;
                }
            } elsif ($value eq '!') {
                if ($fval ne '') {
                    $match = 0;
                    last;
                }
            } elsif ($field->{mode} eq '=') {
                if ($fval ne $value) {
                    $match = 0;
                    last;
                }
            } elsif($field->{mode} eq '~') {
                if ($fval !~ m/\Q$value\E/i) {
                    $match = 0;
                    last;
                }
            }
        }
        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->get_field_name($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} = 1;
    }
    for(my $i = $min; $i <= $max; $i++) {
        $existsid{$i} or return $i;
    }
    return;
}

sub text_dump {
    my ($self, $handle, $options, $base) = @_;

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

    foreach my $attr (sort { $a cmp $b } $base->list_canonical_fields($otype,
        $options->{only_rw} ? 'rw' : 'r')) {
        my $wok = $base->get_field_name($otype, $attr, 'w');
        if (ref $self) {
            my $val = $self->get_c_field($attr);
            if ($val || $options->{empty_attr}) {
            my @vals = ref $val ? @{ $val } : $val;
                foreach (@vals) {
                    $_ ||= '';
                    s/\r?\n/\\n/g;
                    printf($handle "%s%s: %s\n", 
                        $wok ? '' : '# (ro) ',
                        $attr, $_);
                }
            }
        } else {
            printf($handle "%s%s: %s\n", 
                $wok ? '' : '# (ro) ',
                $attr, '');
        }
    }
    return 1;
}

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