use
SPOPS
qw( DEBUG _w )
;
@SPOPS::LDAP::ISA
=
qw( SPOPS )
;
$SPOPS::LDAP::VERSION
=
'1.90'
;
$SPOPS::LDAP::Revision
=
substr
(
q$Revision: 1.34 $
, 10);
sub
no_insert {
return
$_
[0]->CONFIG->{no_insert} || {} }
sub
no_update {
return
$_
[0]->CONFIG->{no_update} || {} }
sub
skip_undef {
return
$_
[0]->CONFIG->{skip_undef} || {} }
sub
base_dn {
unless
(
$_
[0]->CONFIG->{ldap_base_dn} ) {
SPOPS::Exception->throw(
"No Base DN defined"
);
}
return
$_
[0]->CONFIG->{ldap_base_dn};
}
sub
id_value_field {
return
$_
[0]->CONFIG->{id_value_field} }
sub
ldap_object_class {
return
$_
[0]->CONFIG->{ldap_object_class} }
sub
ldap_fetch_object_class {
return
$_
[0]->CONFIG->{ldap_fetch_object_class} }
sub
ldap_update_only_changed {
return
$_
[0]->CONFIG->{ldap_update_only_changed} }
sub
get_superuser_id {
return
$_
[0]->CONFIG->{ldap_root_dn} }
sub
get_supergroup_id {
return
$_
[0]->CONFIG->{ldap_root_group_dn} }
sub
is_superuser {
my
(
$class
,
$id
) =
@_
;
return
(
$id
eq
$class
->get_superuser_id );
}
sub
is_supergroup {
my
(
$class
,
@id
) =
@_
;
my
$super_gid
=
$class
->get_supergroup_id;
return
grep
{
$_
eq
$super_gid
}
@id
;
}
sub
global_datasource_handle {
return
undef
}
sub
connection_info {
return
undef
}
sub
behavior_factory {
my
(
$class
) =
@_
;
DEBUG && _w( 2,
"Installing SPOPS::LDAP behaviors for ($class)"
);
return
{
read_code
=> \
&SPOPS::ClassFactory::LDAP::conf_read_code
,
has_a
=> \
&SPOPS::ClassFactory::LDAP::conf_relate_has_a
,
links_to
=> \
&SPOPS::ClassFactory::LDAP::conf_relate_links_to
,
fetch_by
=> \
&SPOPS::ClassFactory::LDAP::conf_fetch_by
, };
}
sub
class_initialize {
my
(
$class
) =
@_
;
my
$C
=
$class
->CONFIG;
$C
->{field_list} = [
sort
{
$C
->{field}{
$a
} <=>
$C
->{field}{
$b
} }
keys
%{
$C
->{field} } ];
$class
->_class_initialize;
return
1;
}
sub
_class_initialize {}
sub
dn {
my
(
$self
,
$dn
) =
@_
;
unless
(
ref
$self
) {
SPOPS::Exception->throw(
"Cannot call dn() as class method"
);
}
$self
->{tmp_dn} =
$dn
if
(
$dn
);
return
$self
->{tmp_dn};
}
sub
create_id_filter {
my
(
$item
,
$id
) =
@_
;
return
join
(
'='
,
$item
->id_field,
$id
)
if
(
$id
);
unless
(
ref
$item
) {
SPOPS::Exception->throw(
"Cannot create ID filter with a class method call and no ID"
);
}
return
join
(
'='
,
$item
->id_field,
$item
->id );
}
sub
fetch {
my
(
$class
,
$id
,
$p
) =
@_
;
$p
||= {};
DEBUG && _w( 2,
"Trying to fetch an item of $class with ID $id and params "
,
join
" // "
,
map
{
$_
.
' -> '
. (
defined
(
$p
->{
$_
} ) ?
$p
->{
$_
} :
''
) }
keys
%{
$p
} );
return
undef
unless
(
$id
or
$p
->{filter} );
my
$info
=
$class
->_perform_prefetch(
$p
);
my
$filter
= (
$p
->{no_filter} )
?
''
:
$p
->{filter} ||
$class
->create_id_filter(
$id
);
my
$entry
=
$class
->_fetch_single_entry({
connect_key
=>
$p
->{connect_key},
ldap
=>
$p
->{ldap},
base
=>
$p
->{base},
scope
=>
$p
->{scope},
filter
=>
$filter
});
unless
(
$entry
) {
DEBUG && _w( 1,
"No entry found matching object ID ($id)"
);
return
undef
;
}
my
$obj
=
$class
->_perform_postfetch(
$p
,
$info
,
$entry
);
return
$obj
;
}
sub
_perform_prefetch {
my
(
$class
,
$p
,
$info
) =
@_
;
$info
||= {};
$info
->{delay_security_check} = ( !
$p
->{id} and
$p
->{filter} ) ? 1 : 0;
$info
->{level} =
$p
->{security_level};
unless
(
$info
->{delay_security_check} or
$p
->{skip_security} ) {
$info
->{level} ||=
$class
->check_action_security({
id
=>
$p
->{id},
required
=> SEC_LEVEL_READ });
}
return
undef
unless
(
$class
->pre_fetch_action({ %{
$p
},
id
=>
$p
->{id} }) );
DEBUG && _w( 1,
"Pre fetch actions executed ok"
);
return
$info
;
}
sub
_perform_postfetch {
my
(
$class
,
$p
,
$info
,
$entry
) =
@_
;
DEBUG && _w( 1,
"Single entry found ok; setting values into object"
,
"(Delay security: $info->{delay_security_check})"
);
my
$obj
=
$class
->new({
skip_default_values
=> 1 });
$obj
->_fetch_assign_row(
undef
,
$entry
);
if
(
$info
->{delay_security_check} && !
$p
->{skip_security} ) {
$info
->{level} ||=
$class
->check_action_security({
id
=>
$obj
->id,
required
=> SEC_LEVEL_READ })
}
$obj
->_fetch_post_process(
$p
,
$info
->{level} );
return
$obj
;
}
sub
_fetch_single_entry {
my
(
$class
,
$p
) =
@_
;
my
$ldap
=
$p
->{ldap} ||
$class
->global_datasource_handle(
$p
->{connect_key} );
DEBUG && _w( 1,
"Base DN ("
,
$class
->base_dn(
$p
->{connect_key} ),
")"
,
"and filter <<$p->{filter}>> being used to fetch single object"
);
my
%args
= (
base
=>
$p
->{base} ||
$class
->base_dn(
$p
->{connect_key} ),
scope
=>
$p
->{scope} ||
'sub'
);
$args
{filter} =
$p
->{filter}
if
(
$p
->{filter} );
my
$ldap_msg
=
$ldap
->search(
%args
);
$class
->_check_error(
$ldap_msg
,
'fetch'
);
my
$count
=
$ldap_msg
->count;
if
(
$count
> 1 ) {
SPOPS::Exception::LDAP->throw(
"Trying to retrieve unique record, retrieved [$count]"
,
{
filter
=>
$p
->{filter} } );
}
if
(
$count
== 0 ) {
DEBUG && _w( 1,
"No entry found matching filter ($p->{filter})"
);
return
undef
;
}
return
$ldap_msg
->entry( 0 );
}
sub
fetch_by_dn {
my
(
$class
,
$dn
,
$p
) =
@_
;
$p
->{base} =
$dn
;
$p
->{scope} =
'base'
;
$p
->{filter} =
'(objectclass=*)'
;
return
$class
->fetch(
undef
,
$p
);
}
sub
fetch_iterator {
my
(
$class
,
$p
) =
@_
;
DEBUG && _w( 1,
"Trying to create an Iterator with: "
, Dumper(
$p
) );
$p
->{class} =
$class
;
(
$p
->{offset},
$p
->{max} ) =
$class
->fetch_determine_limit(
$p
->{limit} );
unless
(
ref
$p
->{id_list} ) {
$p
->{ldap_msg} =
$class
->_execute_multiple_record_query(
$p
);
$class
->_check_error(
$p
->{ldap_msg},
'fetch_iterator'
);
}
return
SPOPS::Iterator::LDAP->new( { %{
$p
},
skip_default_values
=> 1 });
}
sub
fetch_group {
my
(
$class
,
$p
) =
@_
;
my
(
$offset
,
$max
) =
$class
->fetch_determine_limit(
$p
->{limit} );
my
$ldap_msg
=
$class
->_execute_multiple_record_query(
$p
);
$class
->_check_error(
$ldap_msg
,
'fetch_group'
);
my
$entry_count
= 0;
my
@group
= ();
ENTRY:
while
(
my
$entry
=
$ldap_msg
->shift_entry ) {
my
$obj
=
$class
->new({
skip_default_values
=> 1 });
$obj
->_fetch_assign_row(
undef
,
$entry
);
my
$level
= (
$p
->{skip_security} )
? SEC_LEVEL_WRITE
:
eval
{
$obj
->check_action_security({
required
=> SEC_LEVEL_READ }) };
if
( $@ ) {
DEBUG && _w( 1,
"Security check for object ("
,
$obj
->dn,
")"
,
"in fetch_group() failed, skipping."
);
next
ENTRY;
}
if
(
$offset
and (
$entry_count
<
$offset
) ) {
$entry_count
++;
next
ENTRY
}
last
ENTRY
if
(
$max
and (
$entry_count
>=
$max
) );
$entry_count
++;
$obj
->_fetch_post_process(
$p
,
$level
);
push
@group
,
$obj
;
}
return
\
@group
;
}
sub
_execute_multiple_record_query {
my
(
$class
,
$p
) =
@_
;
my
$filter
=
$p
->{where} ||
$p
->{filter} ||
''
;
if
(
$filter
and
$filter
!~ /^\(.*\)$/ ) {
$filter
=
"($filter)"
;
}
if
( (
my
$fetch_oc
=
$class
->ldap_fetch_object_class ) and
$filter
!~ /objectclass/ ) {
my
$oc_filter
=
"(objectclass=$fetch_oc)"
;
DEBUG && _w( 2,
"Adding filter for object class ($fetch_oc)"
);
$filter
= (
$filter
) ?
"(&$oc_filter$filter)"
:
$oc_filter
;
}
my
$ldap
=
$p
->{ldap} ||
$class
->global_datasource_handle(
$p
->{connect_key} );
DEBUG && _w( 1,
"Base DN ("
,
$class
->base_dn(
$p
->{connect_key} ),
")\nFilter <<$filter>>\n"
,
"being used to fetch one or more objects"
);
return
$ldap
->search(
base
=>
$class
->base_dn(
$p
->{connect_key} ),
scope
=>
'sub'
,
filter
=>
$filter
);
}
sub
_fetch_assign_row {
my
(
$self
,
$field_list
,
$entry
) =
@_
;
DEBUG && _w( 1,
"Setting data from row into"
,
ref
$self
,
"using DN of entry "
,
$entry
->dn );
$self
->clear_all_loaded();
my
$CONF
=
$self
->CONFIG;
$field_list
||=
$self
->field_list;
foreach
my
$field
( @{
$field_list
} ) {
my
@values
=
$entry
->get_value(
$field
);
if
(
$CONF
->{multivalue}{
$field
} ) {
$self
->{
$field
} = \
@values
;
DEBUG && _w( 1,
sprintf
(
" ( multi) %-20s --> %s"
,
$field
,
join
(
'||'
,
@values
) ) );
}
else
{
$self
->{
$field
} =
$values
[0];
DEBUG && _w( 1,
sprintf
(
" (single) %-20s --> %s"
,
$field
,
$values
[0] ) );
}
$self
->set_loaded(
$field
);
}
$self
->dn(
$entry
->dn );
return
$self
;
}
sub
_fetch_post_process {
my
(
$self
,
$p
,
$security_level
) =
@_
;
$self
->set_cached_object(
$p
);
return
undef
unless
(
$self
->post_fetch_action(
$p
) );
$self
->clear_change;
$self
->has_save;
$self
->{tmp_security_level} =
$security_level
;
DEBUG && _w( 1,
ref
$self
,
"("
,
$self
->id,
") : cache set (if available),"
,
"post_fetch_action() done, change flag cleared and save "
,
"flag set. Security: $security_level"
);
return
$self
;
}
sub
save {
my
(
$self
,
$p
) =
@_
;
my
$id
=
$self
->id;
DEBUG && _w( 1,
"Trying to save a ("
,
ref
$self
,
") with ID ($id)"
);
my
$is_add
= (
$p
->{is_add} or !
$self
->saved );
unless
(
$is_add
or
$self
->changed ) {
DEBUG && _w( 1,
"This object exists and has not changed. Exiting."
);
return
$self
;
}
my
(
$level
);
unless
(
$p
->{skip_security} ) {
$level
=
$self
->check_action_security({
required
=> SEC_LEVEL_WRITE,
is_add
=>
$is_add
});
}
DEBUG && _w( 1,
"Security check passed ok. Continuing."
);
return
undef
unless
(
$self
->pre_save_action({ %{
$p
},
is_add
=>
$is_add
}) );
if
(
$is_add
) {
$self
->_save_insert(
$p
) }
else
{
$self
->_save_update(
$p
) }
return
undef
unless
(
$self
->post_save_action({ %{
$p
},
is_add
=>
$is_add
}) );
DEBUG && _w( 1,
"Post save action executed ok."
);
$self
->set_cached_object(
$p
);
my
$action
= (
$is_add
) ?
'create'
:
'update'
;
unless
(
$p
->{skip_log} ) {
$self
->log_action(
$action
,
$self
->id );
}
$self
->has_save;
$self
->clear_change;
return
$self
;
}
sub
_save_insert {
my
(
$self
,
$p
) =
@_
;
$p
||= {};
DEBUG && _w( 1,
'Treating save as INSERT'
);
my
$ldap
=
$p
->{ldap} ||
$self
->global_datasource_handle(
$p
->{connect_key} );
$self
->dn(
$self
->build_dn );
my
$num_objectclass
= (
ref
$self
->{objectclass} )
? @{
$self
->{objectclass} } : 0;
if
(
$num_objectclass
== 0 ) {
$self
->{objectclass} =
$self
->ldap_object_class;
DEBUG && _w( 1,
"Using object class from config in new object ("
,
join
(
', '
, @{
$self
->{objectclass} } ),
")"
);
}
DEBUG && _w( 1,
"Trying to create record with DN: ("
,
$self
->dn,
")"
);
my
%insert_data
= ();
my
$no_insert
=
$self
->no_insert;
foreach
my
$attr
( @{
$self
->field_list } ) {
next
if
(
$no_insert
->{
$attr
} );
$insert_data
{
$attr
} =
$self
->{
$attr
};
if
(
ref
$insert_data
{
$attr
} eq
'ARRAY'
and
scalar
@{
$insert_data
{
$attr
} } == 0 ) {
$insert_data
{
$attr
} =
undef
;
}
}
DEBUG && _w( 1,
"Trying to create a record with:\n"
, Dumper( \
%insert_data
) );
my
$ldap_msg
=
$ldap
->add(
dn
=>
$self
->dn,
attr
=> [
%insert_data
]);
$self
->_check_error(
$ldap_msg
,
'save'
);
DEBUG && _w( 1,
"Record created ok."
);
}
sub
_save_update {
my
(
$self
,
$p
) =
@_
;
$p
||= {};
DEBUG && _w( 1,
"Treating save as UPDATE with DN: ("
,
$self
->dn,
")"
);
my
$ldap
=
$p
->{ldap} ||
$self
->global_datasource_handle(
$p
->{connect_key} );
my
$entry
=
$self
->_fetch_single_entry({
filter
=>
$self
->create_id_filter,
ldap
=>
$ldap
});
DEBUG && _w( 1,
"Loaded entry for update:\n"
, Dumper(
$entry
) );
my
$no_update
=
$self
->no_update;
my
$only_changed
=
$self
->ldap_update_only_changed;
ATTRIB:
foreach
my
$attr
( @{
$self
->field_list } ) {
next
ATTRIB
if
(
$no_update
->{
$attr
} );
my
$object_value
=
$self
->{
$attr
};
if
(
$only_changed
) {
my
@existing_values
=
$entry
->get_value(
$attr
);
DEBUG && _w( 1,
"Toggle for updating only changed values set."
,
"Checking if ($attr) different: "
, Dumper(
$object_value
),
"vs."
, Dumper( \
@existing_values
) );
next
ATTRIB
if
(
$self
->_values_are_same(
$object_value
, \
@existing_values
) );
DEBUG && _w( 1,
"Values for ($attr) are different. Updating..."
);
}
if
(
ref
$object_value
eq
'ARRAY'
and
scalar
@{
$object_value
} == 0 ) {
$object_value
=
undef
;
}
$entry
->replace(
$attr
,
$object_value
);
}
DEBUG && _w( 1,
"Entry before Update:\n"
, Dumper(
$entry
) );
my
$ldap_msg
=
$entry
->update(
$ldap
);
$self
->_check_error(
$ldap_msg
,
'save'
);
DEBUG && _w( 1,
"Record updated ok."
);
}
sub
_values_are_same {
my
(
$self
,
$val1
,
$val2
) =
@_
;
$val1
= (
ref
$val1
) ?
$val1
: [
$val1
];
$val2
= (
ref
$val2
) ?
$val2
: [
$val2
];
my
%v1
=
map
{
$_
=> 1 } @{
$val1
};
my
%v2
=
map
{
$_
=> 1 } @{
$val2
};
foreach
my
$field
(
keys
%v1
) {
return
undef
unless
(
$v2
{
$field
} );
}
foreach
my
$field
(
keys
%v2
) {
return
undef
unless
(
$v1
{
$field
} );
}
return
1;
}
sub
remove {
my
(
$self
,
$p
) =
@_
;
return
undef
unless
(
$self
->is_saved );
my
$level
= SEC_LEVEL_WRITE;
unless
(
$p
->{skip_security} ) {
$level
=
$self
->check_action_security({
required
=> SEC_LEVEL_WRITE });
}
DEBUG && _w( 1,
"Security check passed ok. Continuing."
);
return
undef
unless
(
$self
->pre_remove_action(
$p
) );
my
$id
=
$self
->id;
my
$dn
=
$self
->dn;
my
$ldap
=
$p
->{ldap} ||
$self
->global_datasource_handle(
$p
->{connect_key} );;
my
$ldap_msg
=
$ldap
->
delete
(
$dn
);
$self
->_check_error(
$ldap_msg
,
'remove'
);
if
(
$self
->use_cache(
$p
) ) {
$self
->global_cache->clear({
data
=>
$self
});
}
return
undef
unless
(
$self
->post_remove_action(
$p
) );
$self
->log_action(
'delete'
,
$id
)
unless
(
$p
->{skip_log} );
$self
->clear_change;
$self
->clear_save;
return
1;
}
sub
_check_error {
my
(
$class
,
$ldap_msg
,
$action
) =
@_
;
my
$code
=
$ldap_msg
->code;
return
undef
unless
(
$code
);
SPOPS::Exception::LDAP->throw(
Net::LDAP::Util::ldap_error_desc(
$code
),
{
code
=>
$code
,
action
=>
$action
,
error_name
=> Net::LDAP::Util::ldap_error_name(
$code
),
error_text
=> Net::LDAP::Util::ldap_error_text(
$code
) } );
}
sub
build_dn {
my
(
$item
,
$p
) =
@_
;
my
$base_dn
=
$p
->{base_dn} ||
$item
->base_dn(
$p
->{connect_key} );
my
$id_field
=
$p
->{id_field} ||
$item
->id_field;
my
$id_value_field
=
$p
->{id_value_field} ||
$item
->id_value_field;
my
$id_value
=
$p
->{id};
unless
(
$id_value
) {
unless
(
ref
$item
) {
SPOPS::Exception->throw(
"Cannot create DN for object without an ID value as "
.
"parameter when called as class method"
);
}
$id_value
=
$item
->{
$id_value_field
} ||
$item
->id;
unless
(
$id_value
) {
SPOPS::Exception->throw(
"Cannot create DN for object without an ID value"
);
}
}
unless
(
$id_field
and
$id_value
and
$base_dn
) {
SPOPS::Exception->throw(
"Cannot create Base DN without all parts: "
,
"field: [$id_field]; ID: [$id_value]; BaseDN: [$base_dn]"
);
}
return
join
(
','
,
join
(
'='
,
$id_field
,
$id_value
),
$base_dn
);
}
1;