source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Unix/User.pm @ 1352

package LATMOS::Accounts::Bases::Unix::User;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases::Objects);
use LATMOS::Accounts::Log;

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

=head1 NAME

LATMOS::Ad - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases;
  my $base = LATMOS::Accounts::Bases->new('unix');
  ...

=head1 DESCRIPTION

Account base access over standard unix file format.

=head1 FUNCTIONS

=cut

sub _get_attr_schema {
    my ($class, $base) = @_;
    {
        uidNumber       => { iname => 'uid', uniq => 1, },
        gidNumber       => { iname => 'gid',
            can_values => sub {
                map { $_->get_attributes('gidNumber') }
                map { $base->get_object('group', $_) }
                $base->list_objects('group')
            },
            reference => 'group',
            mandatory => 1,
        },
        gecos           => { },
        homeDirectory   => { iname => 'home' },
        loginShell      => { iname => 'shell' },
        userPassword    => {
            iname => ($base->{use_shadow} ? 'spassword' : 'password'),
        },
        memberOf        => {
            delayed => 1,
            multiple => 1,
        },
        locked          => {},
        givenName       => { ro => 1 },
        sn              => { ro => 1 },
        uid             => { iname => 'login', ro => 1 },
        sAMAccountName  => { iname => 'login', ro => 1 },
        $base->{use_shadow} ?
        (
            shadowLastChange => { iname => 'last_changed' },
            shadowMin        => { iname => 'before_ch' },
            shadowMax        => { iname => 'after_ch' },
            shadowWarning    => { iname => 'exp_warn' },
            shadowInactive   => { iname => 'exp_disable' },
            shadowExpire     => { iname => 'disable' },
            shadowFlag       => { iname => 'res' },
        ) : (),
    };
}

=head2 new(%config)

=cut

sub new {
    my ($class, $base, $id, @args) = @_;
    # we profit of ref, quite easy
    if (exists($base->{users}{$id}) && $base->{users}{$id}) {
        if ($base->{users}{$id}{uid} < ($base->{min_uid} || 0)) {
            return;
        }
        return bless($base->{users}{$id}, $class);
    } else { return }
}

sub id {
    $_[0]->{account}
}

sub get_field {
    my ($self, $field) = @_;
    for ($field) {
        /^login$/ and return $self->id;
        /^(sn|givenName)$/ and do {
            my $gecos = $self->{gecos} || '';
            my ($given, $sn) = $gecos =~ /^([^, ]+) +([^, ]+)/;
            return $field eq 'sn' ? $sn : $given;
        };
        /^memberOf$/ and do {
            my @res;
            foreach (sort keys %{ $self->base->{groups} || {}}) {
                push(@res, $_)
                    if(exists($self->base->{groups}{$_}{'users'}{$self->id}));
            }
            return \@res;
        };
    }
    $self->{$field}
}

sub set_fields {
    my ($self, %data) = @_;
    foreach my $field (keys %data) {
        $field =~ /^(uid|gid)$/ and do {
            if(!(defined($data{$field}) && $data{$field} =~ /^\d+$/)) {
                $self->base->log(LA_ERR,
                    "Invalid data for $field: " . ($data{$field} || ''));
                return;
            }
        }
    }
    foreach my $field (keys %data) {
        # TODO check fields exists !
        $field =~ /^(sn|givenName)$/ and next;
        $field eq 'memberOf' and do {
            my %set;
            foreach(@{ $data{$field} || []}) {
                $set{$_} = 1;
            }
            foreach (sort keys %{ $self->base->{groups} || {}}) {
                if ($set{$_}) {
                    $self->base->{groups}{$_}{'users'}{$self->id} = 1;
                } else {
                    delete($self->base->{groups}{$_}{'users'}{$self->id});
                }
            }
        };
        $self->{$field} = $data{$field};
    }
    1;
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Bases::Unix>

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS

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