[2] | 1 | package LATMOS::Accounts::Bases; |
---|
| 2 | |
---|
| 3 | use 5.010000; |
---|
| 4 | use strict; |
---|
| 5 | use warnings; |
---|
| 6 | use LATMOS::Accounts::Bases::Objects; |
---|
[852] | 7 | use LATMOS::Accounts::Bases::Attributes; |
---|
[210] | 8 | use LATMOS::Accounts::Log; |
---|
[765] | 9 | use LATMOS::Accounts::Utils qw(exec_command to_ascii); |
---|
[2] | 10 | |
---|
[3] | 11 | our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0]; |
---|
[2] | 12 | |
---|
[3] | 13 | =head1 NAME |
---|
| 14 | |
---|
| 15 | LATMOS::Accounts::Bases - Base class for account data bases |
---|
| 16 | |
---|
| 17 | =head1 SYNOPSIS |
---|
| 18 | |
---|
| 19 | use LATMOS::Accounts::Bases; |
---|
| 20 | my $base = LATMOS::Accounts::Bases->new('type', %options); |
---|
| 21 | ... |
---|
| 22 | |
---|
| 23 | =head1 DESCRIPTION |
---|
| 24 | |
---|
| 25 | This module provide basic functions for various account base |
---|
| 26 | |
---|
[1070] | 27 | =head1 FUNCTIONS |
---|
[3] | 28 | |
---|
| 29 | =cut |
---|
| 30 | |
---|
| 31 | =head2 new($type, %options) |
---|
| 32 | |
---|
| 33 | Return, if success, a new data base account object, $type is |
---|
| 34 | account base type, %options to setup the base. |
---|
| 35 | |
---|
| 36 | =cut |
---|
| 37 | |
---|
[2] | 38 | sub new { |
---|
[1071] | 39 | my ($class, $type, $options) = @_; |
---|
[2] | 40 | |
---|
| 41 | my $pclass = ucfirst(lc($type)); |
---|
| 42 | eval "require LATMOS::Accounts::Bases::$pclass;"; |
---|
[1223] | 43 | if ($@) { |
---|
| 44 | la_log(LA_DEBUG, "Failed to load base type `%s': %s", $type, $@); |
---|
| 45 | return |
---|
| 46 | } |
---|
[1071] | 47 | my $base = "LATMOS::Accounts::Bases::$pclass"->new(%{$options->{params}}) |
---|
[1039] | 48 | or return; |
---|
[41] | 49 | $base->{_type} = lc($pclass); |
---|
[1071] | 50 | $base->{_label} = $options->{label}; |
---|
| 51 | $base->{_options} = $options->{params}; |
---|
[282] | 52 | $base->{wexported} = 0; |
---|
[1071] | 53 | $base->{defattr} = $options->{defattr}; |
---|
| 54 | $base->{_acls} = $options->{acls}; |
---|
| 55 | $base->{_allowed_values} = $options->{allowed_values}; |
---|
| 56 | $base->{_la} = $options->{la}; |
---|
| 57 | la_log(LA_DEBUG, 'Instanciate base %s (%s)', ($base->label || 'N/A'), $pclass); |
---|
[41] | 58 | $base |
---|
[2] | 59 | } |
---|
| 60 | |
---|
[1023] | 61 | =head2 wexported |
---|
| 62 | |
---|
| 63 | See L</unexported> |
---|
| 64 | |
---|
| 65 | =cut |
---|
| 66 | |
---|
[849] | 67 | sub wexported { unexported(@_) } |
---|
| 68 | |
---|
[1023] | 69 | =head2 unexported ($wexported) |
---|
| 70 | |
---|
| 71 | Set base to report unexported object or not |
---|
| 72 | |
---|
| 73 | =cut |
---|
| 74 | |
---|
[849] | 75 | sub unexported { |
---|
[282] | 76 | my ($self, $wexported) = @_; |
---|
| 77 | my $old = $self->{wexported}; |
---|
[284] | 78 | if (defined($wexported)) { |
---|
| 79 | $self->{wexported} = $wexported; |
---|
[285] | 80 | $self->log(LA_DEBUG, "Switching exported mode: %s => %s", $old, |
---|
[284] | 81 | $wexported); |
---|
| 82 | } |
---|
[282] | 83 | return($old || 0); |
---|
| 84 | } |
---|
| 85 | |
---|
[1182] | 86 | =head2 temp_switch_unexported($CODE, $value) |
---|
| 87 | |
---|
| 88 | Switch the base to unexported mode given by C<$value>, run C<$CODE>, restore |
---|
| 89 | back the previous state and return the result of code ref. |
---|
| 90 | |
---|
| 91 | =cut |
---|
| 92 | |
---|
| 93 | sub temp_switch_unexported (&;$) { |
---|
| 94 | my ($self, $sub, $value) = @_; |
---|
| 95 | |
---|
| 96 | my $old = $self->unexported($value || 0); |
---|
| 97 | my $res = $sub->(); |
---|
| 98 | $self->unexported($old); |
---|
| 99 | return $res; |
---|
| 100 | } |
---|
| 101 | |
---|
[861] | 102 | =head2 log($level, $msg, $arg) |
---|
| 103 | |
---|
| 104 | Log a message prefixed by database information |
---|
| 105 | |
---|
| 106 | =cut |
---|
| 107 | |
---|
[274] | 108 | sub log { |
---|
| 109 | my ($self, $level, $msg, @args) = @_; |
---|
[304] | 110 | my $prefix = 'Base(' . $self->type . '/' . $self->label . ')'; |
---|
[274] | 111 | LATMOS::Accounts::Log::la_log($level, "$prefix $msg", @args); |
---|
| 112 | } |
---|
| 113 | |
---|
[1294] | 114 | =head2 ReportChange($otype, $name, $ref, $changetype, $message, @args) |
---|
| 115 | |
---|
| 116 | Functions to report back |
---|
| 117 | |
---|
| 118 | =cut |
---|
| 119 | |
---|
| 120 | sub ReportChange { |
---|
| 121 | my ($self, $otype, $name, $ref, $changetype, $message, @args) = @_; |
---|
| 122 | |
---|
| 123 | } |
---|
| 124 | |
---|
[861] | 125 | =head2 label |
---|
| 126 | |
---|
| 127 | Return the database label |
---|
| 128 | |
---|
| 129 | =cut |
---|
| 130 | |
---|
[49] | 131 | sub label { |
---|
[304] | 132 | $_[0]->{_label} || 'NoLabel'; |
---|
[49] | 133 | } |
---|
| 134 | |
---|
[1023] | 135 | =head2 type |
---|
| 136 | |
---|
| 137 | Return the type of the base |
---|
| 138 | |
---|
| 139 | =cut |
---|
| 140 | |
---|
[41] | 141 | sub type { |
---|
| 142 | $_[0]->{_type}; |
---|
| 143 | } |
---|
| 144 | |
---|
[959] | 145 | =head2 la |
---|
| 146 | |
---|
| 147 | return LATMOS::Accounts object parent to the base |
---|
| 148 | |
---|
| 149 | =cut |
---|
| 150 | |
---|
| 151 | sub la { $_[0]->{_la} }; |
---|
| 152 | |
---|
[1071] | 153 | =head2 config ($opt) |
---|
[1023] | 154 | |
---|
| 155 | Return options from config |
---|
| 156 | |
---|
| 157 | =cut |
---|
| 158 | |
---|
[1071] | 159 | sub config { |
---|
[861] | 160 | my ($self, $opt) = @_; |
---|
| 161 | return $self->{_options}{$opt}; |
---|
[683] | 162 | } |
---|
| 163 | |
---|
[41] | 164 | =head2 list_supported_objects(@otype) |
---|
| 165 | |
---|
| 166 | Return a list of supported object |
---|
| 167 | |
---|
| 168 | @type is an additionnal list of objects to check |
---|
| 169 | |
---|
| 170 | =cut |
---|
| 171 | |
---|
| 172 | sub list_supported_objects { |
---|
| 173 | my ($self, @otype) = @_; |
---|
[146] | 174 | my %res; |
---|
| 175 | foreach my $inc (@INC) { |
---|
| 176 | my $sub = 'LATMOS::Accounts::Bases::' . ucfirst($self->type); |
---|
| 177 | $sub =~ s/::/\//g; |
---|
| 178 | foreach (glob("$inc/$sub/[A-Z]*.pm")) { |
---|
| 179 | s/.*\///; |
---|
| 180 | s/\.pm$//; |
---|
| 181 | $res{lc($_)} = 1; |
---|
| 182 | } |
---|
| 183 | } |
---|
| 184 | $res{$_} = 1 foreach(@otype); |
---|
[210] | 185 | my @sobj = grep { $self->is_supported_object($_) } keys %res; |
---|
| 186 | la_log(LA_DEBUG, "Base %s supported objects: %s", $self->type, join(', ', @sobj)); |
---|
| 187 | return @sobj; |
---|
[41] | 188 | } |
---|
| 189 | |
---|
[1023] | 190 | =head2 ordered_objects |
---|
| 191 | |
---|
| 192 | Return supported object type ordered in best order for synchronisation |
---|
| 193 | |
---|
| 194 | =cut |
---|
| 195 | |
---|
[861] | 196 | sub ordered_objects { |
---|
| 197 | my ($self) = @_; |
---|
| 198 | |
---|
| 199 | my %deps; |
---|
| 200 | my %maxdeps; |
---|
| 201 | my @objs = sort { $b cmp $a } $self->list_supported_objects; |
---|
| 202 | foreach my $obj (@objs) { |
---|
| 203 | foreach my $at ($self->list_canonical_fields($obj)) { |
---|
| 204 | my $attr = $self->attribute($obj, $at); |
---|
| 205 | $attr->ro and next; |
---|
| 206 | $attr->{delayed} and next; |
---|
| 207 | if (my $res = $attr->reference) { |
---|
| 208 | $deps{$obj}{$res} ||= 1; |
---|
| 209 | if ($attr->mandatory) { |
---|
| 210 | $deps{$obj}{$res} = 2; |
---|
| 211 | $maxdeps{$res} = 1; |
---|
| 212 | } |
---|
| 213 | } |
---|
| 214 | } |
---|
| 215 | } |
---|
| 216 | |
---|
| 217 | sort { |
---|
| 218 | if (keys %{$deps{$a} || {}}) { |
---|
| 219 | if (keys %{$deps{$b} || {}}) { |
---|
| 220 | return ( |
---|
| 221 | ($deps{$a}{$b} || 0) > ($deps{$b}{$a} || 0) ? 1 : |
---|
| 222 | ($deps{$b}{$a} || 0) > ($deps{$a}{$b} || 0) ? -1 : |
---|
| 223 | ($maxdeps{$b} || 0) - ($maxdeps{$a} || 0) |
---|
| 224 | ); |
---|
| 225 | } else { |
---|
| 226 | return 1; |
---|
| 227 | } |
---|
| 228 | } elsif (keys %{$deps{$b} || {}}) { |
---|
| 229 | return -1; |
---|
| 230 | } else { |
---|
| 231 | return ($maxdeps{$b} || 0) - ($maxdeps{$a} || 0) |
---|
| 232 | } |
---|
| 233 | } @objs; |
---|
| 234 | } |
---|
| 235 | |
---|
| 236 | sub _load_obj_class { |
---|
| 237 | my ($self, $otype) = @_; |
---|
| 238 | |
---|
| 239 | # finding perl class: |
---|
| 240 | my $pclass = ref $self; |
---|
| 241 | $pclass .= '::' . ucfirst(lc($otype)); |
---|
| 242 | eval "require $pclass;"; |
---|
| 243 | if ($@) { |
---|
| 244 | $self->log(LA_DEBUG, 'Cannot load perl class %s', $pclass); |
---|
| 245 | return |
---|
| 246 | } # error message ? |
---|
| 247 | return $pclass; |
---|
| 248 | } |
---|
| 249 | |
---|
| 250 | |
---|
[41] | 251 | =head2 is_supported_object($otype) |
---|
| 252 | |
---|
| 253 | Return true is object type $otype is supported |
---|
| 254 | |
---|
| 255 | =cut |
---|
| 256 | |
---|
| 257 | sub is_supported_object { |
---|
| 258 | my ($self, $otype) = @_; |
---|
[892] | 259 | |
---|
| 260 | if (my $pclass = $self->_load_obj_class($otype)) { |
---|
| 261 | if ($pclass->can('is_supported')) { |
---|
| 262 | return $pclass->is_supported($self); |
---|
| 263 | } else { |
---|
| 264 | return 1; |
---|
| 265 | } |
---|
| 266 | } else { |
---|
| 267 | return 0; |
---|
| 268 | } |
---|
[41] | 269 | } |
---|
| 270 | |
---|
[28] | 271 | =head2 list_objects($otype) |
---|
| 272 | |
---|
| 273 | Return the list of UID for object of $otype. |
---|
| 274 | |
---|
| 275 | =cut |
---|
| 276 | |
---|
| 277 | sub list_objects { |
---|
| 278 | my ($self, $otype) = @_; |
---|
| 279 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 280 | $pclass->list($self); |
---|
| 281 | } |
---|
| 282 | |
---|
[3] | 283 | =head2 get_object($type, $id) |
---|
| 284 | |
---|
| 285 | Return an object of $type (typically user or group) having identifier |
---|
| 286 | $id. |
---|
| 287 | |
---|
| 288 | =cut |
---|
| 289 | |
---|
[2] | 290 | sub get_object { |
---|
| 291 | my ($self, $otype, $id) = @_; |
---|
| 292 | |
---|
[27] | 293 | return LATMOS::Accounts::Bases::Objects->_new($self, $otype, $id); |
---|
[2] | 294 | } |
---|
| 295 | |
---|
[16] | 296 | =head2 create_object($type, $id, %data) |
---|
| 297 | |
---|
| 298 | Create and return an object of type $type with unique id |
---|
| 299 | $id having %data. |
---|
| 300 | |
---|
| 301 | This method should be provided by the data base handler. |
---|
| 302 | |
---|
| 303 | =cut |
---|
| 304 | |
---|
| 305 | sub create_object { |
---|
| 306 | my ($self, $otype, $id, %data) = @_; |
---|
[861] | 307 | "$id" or do { |
---|
| 308 | $self->log(LA_ERR, "Cannot create %s object with empty id", |
---|
| 309 | $otype); |
---|
| 310 | return; |
---|
| 311 | }; |
---|
[1104] | 312 | my $pclass = $self->_load_obj_class($otype) or do { |
---|
| 313 | $self->log(LA_ERR, "Cannot create %s object type (cannot load class)", |
---|
| 314 | $otype); |
---|
| 315 | return; |
---|
| 316 | }; |
---|
[257] | 317 | if ($pclass->_create($self, $id, %data)) { |
---|
| 318 | la_log(LA_INFO, |
---|
| 319 | 'Object %s (%s) created in base %s (%s)', |
---|
| 320 | $id, $otype, $self->label, $self->type |
---|
| 321 | ); |
---|
| 322 | } else { |
---|
[212] | 323 | la_log(LA_ERR, |
---|
[210] | 324 | 'Object creation %s (%s) in base %s (%s) failed', |
---|
| 325 | $id, $otype, $self->label, $self->type |
---|
| 326 | ); |
---|
[197] | 327 | return; |
---|
| 328 | }; |
---|
[27] | 329 | $self->get_object($otype, $id); |
---|
[16] | 330 | } |
---|
| 331 | |
---|
| 332 | =head2 create_c_object($type, $id, %data) |
---|
| 333 | |
---|
| 334 | Create and return an object of type $type with unique id |
---|
| 335 | $id having %data using canonical fields |
---|
| 336 | |
---|
| 337 | =cut |
---|
| 338 | |
---|
| 339 | sub create_c_object { |
---|
| 340 | my ($self, $otype, $id, %cdata) = @_; |
---|
[488] | 341 | $self->check_acl($otype, '@CREATE', 'w') or do { |
---|
| 342 | $self->log(LA_WARN, 'permission denied to create object type %s', |
---|
| 343 | $otype); |
---|
| 344 | return; |
---|
| 345 | }; |
---|
[861] | 346 | |
---|
| 347 | $self->_create_c_object($otype, $id, %cdata); |
---|
| 348 | } |
---|
| 349 | |
---|
[1076] | 350 | =head2 compute_default($otype, $id, %cdata) |
---|
| 351 | |
---|
| 352 | Return a hash containing value to set for new object |
---|
| 353 | |
---|
| 354 | =cut |
---|
| 355 | |
---|
| 356 | sub compute_default { |
---|
[861] | 357 | my ($self, $otype, $id, %cdata) = @_; |
---|
[959] | 358 | |
---|
[1076] | 359 | my %default; |
---|
[365] | 360 | foreach my $def (keys %{ $self->{defattr} || {}}) { |
---|
[137] | 361 | if ($def =~ /^$otype\.(.*)$/) { |
---|
[1076] | 362 | $default{$1} = $self->{defattr}{$def} if(!$cdata{$1}); |
---|
[137] | 363 | } |
---|
| 364 | } |
---|
[1076] | 365 | |
---|
| 366 | # computed default value (not a simple set) |
---|
[598] | 367 | if (lc($otype) eq 'user') { |
---|
[1076] | 368 | if (!$cdata{homeDirectory}) { |
---|
| 369 | $default{homeDirectory} = $self->{defattr}{'user.homebase'} |
---|
| 370 | ? $self->{defattr}{'user.homebase'} . "/$id" |
---|
| 371 | : ''; |
---|
| 372 | } |
---|
| 373 | |
---|
| 374 | if (!$cdata{uidNumber}) { |
---|
| 375 | $default{uidNumber} ||= $self->find_next_numeric_id('user', 'uidNumber', |
---|
[137] | 376 | $self->{defattr}{'user.min_uid'}, $self->{defattr}{'user.max_uid'}); |
---|
[1076] | 377 | } |
---|
| 378 | |
---|
[765] | 379 | my $mailid = $cdata{givenName} && $cdata{sn} |
---|
| 380 | ? sprintf('%s.%s', |
---|
| 381 | to_ascii(lc($cdata{givenName})), |
---|
| 382 | to_ascii(lc($cdata{sn})),) |
---|
| 383 | : undef; |
---|
[1076] | 384 | $mailid =~ s/\s+/-/g if($mailid); |
---|
[765] | 385 | |
---|
| 386 | if ($mailid && |
---|
| 387 | $self->is_supported_object('aliases') && |
---|
| 388 | ! $self->get_object('aliases', $mailid)) { |
---|
[861] | 389 | if (my $attr = $self->attribute($otype, 'mail')) { |
---|
| 390 | if ((!$attr->ro) && $self->{defattr}{'user.maildomain'}) { |
---|
[1076] | 391 | $default{mail} ||= sprintf('%s@%s', |
---|
[765] | 392 | $mailid, |
---|
| 393 | $self->{defattr}{'user.maildomain'}); |
---|
| 394 | } |
---|
| 395 | } |
---|
[861] | 396 | if (my $attr = $self->attribute($otype, 'aliases')) { |
---|
[1076] | 397 | $default{aliases} ||= $mailid unless ($attr->ro); |
---|
[765] | 398 | } |
---|
[861] | 399 | if (my $attr = $self->attribute($otype, 'revaliases')) { |
---|
[1076] | 400 | $default{revaliases} ||= $mailid unless ($attr->ro); |
---|
[765] | 401 | } |
---|
| 402 | } |
---|
[598] | 403 | } elsif (lc($otype) eq 'group') { |
---|
[1076] | 404 | if (!$cdata{gidNumber}) { |
---|
| 405 | $default{gidNumber} ||= $self->find_next_numeric_id( |
---|
| 406 | 'group', 'gidNumber', |
---|
| 407 | $self->{defattr}{'group.min_gid'}, |
---|
| 408 | $self->{defattr}{'group.max_gid'} |
---|
| 409 | ); |
---|
| 410 | } |
---|
[137] | 411 | } |
---|
[1076] | 412 | |
---|
| 413 | return %default; |
---|
| 414 | } |
---|
| 415 | |
---|
| 416 | sub _create_c_object { |
---|
| 417 | my ($self, $otype, $id, %cdata) = @_; |
---|
| 418 | |
---|
| 419 | $id ||= ''; # Avoid undef |
---|
| 420 | |
---|
| 421 | if (my $chk = ( |
---|
| 422 | lc($otype) eq 'user' || lc($otype) eq 'group') |
---|
| 423 | ? LATMOS::Accounts::Utils::check_ug_validity($id) |
---|
| 424 | : LATMOS::Accounts::Utils::check_oid_validity($id)) { |
---|
| 425 | $self->log(LA_ERR, "Cannot create $otype with ID $id `%s:'", $chk); |
---|
| 426 | return; |
---|
| 427 | } |
---|
| 428 | foreach my $cfield (keys %cdata) { |
---|
| 429 | $self->check_allowed_values($otype, $cfield, $cdata{$cfield}) or do { |
---|
| 430 | $self->log(LA_ERR, "Cannot create $otype, wrong value"); |
---|
| 431 | return; |
---|
| 432 | }; |
---|
| 433 | } |
---|
| 434 | |
---|
| 435 | # populating default value |
---|
| 436 | { |
---|
| 437 | my %default = $self->compute_default($otype, $id, %cdata); |
---|
| 438 | foreach my $k (keys %default) { |
---|
| 439 | $cdata{$k} = $default{$k}; |
---|
| 440 | } |
---|
| 441 | } |
---|
| 442 | |
---|
[16] | 443 | my %data; |
---|
| 444 | foreach my $cfield (keys %cdata) { |
---|
[861] | 445 | my $attribute = $self->attribute($otype, $cfield) or next; |
---|
| 446 | $attribute->ro and next; |
---|
| 447 | $data{$attribute->iname} = $cdata{$cfield}; |
---|
[16] | 448 | } |
---|
[861] | 449 | #keys %data or return 0; # TODO: return an error ? |
---|
[1294] | 450 | my $obj = $self->create_object($otype, $id, %data) or return; |
---|
| 451 | $obj->ReportChange('Create', 'Object created with %s', join(', ', sort keys %cdata)); |
---|
| 452 | |
---|
| 453 | foreach my $attrname (keys %data) { |
---|
| 454 | my $attribute = $self->attribute($obj->type, $attrname) or next; |
---|
| 455 | $obj->ReportChange('Attributes', '%s set to %s', $attrname, |
---|
| 456 | (ref $data{$attrname} |
---|
| 457 | ? join(', ', @{ $data{$attrname} }) |
---|
| 458 | : $data{$attrname}) || '(none)') if ($attribute->{notify}); |
---|
| 459 | } |
---|
| 460 | |
---|
| 461 | $obj |
---|
[16] | 462 | } |
---|
| 463 | |
---|
[861] | 464 | sub _allowed_values { |
---|
| 465 | $_[0]->{_allowed_values} |
---|
| 466 | } |
---|
| 467 | |
---|
[1023] | 468 | =head2 obj_attr_allowed_values ($otype, $attr) |
---|
| 469 | |
---|
| 470 | Return value allowed for this attribute |
---|
| 471 | |
---|
| 472 | =cut |
---|
| 473 | |
---|
[861] | 474 | sub obj_attr_allowed_values { |
---|
| 475 | my ($self, $otype, $attr) = @_; |
---|
| 476 | if ($self->_allowed_values && |
---|
| 477 | $self->_allowed_values->SectionExists("$otype.$attr")) { |
---|
| 478 | return grep { defined($_) } $self->_allowed_values->val("$otype.$attr", 'allowed'); |
---|
| 479 | } |
---|
| 480 | return(); |
---|
| 481 | } |
---|
| 482 | |
---|
[1023] | 483 | =head2 check_allowed_values ($otype, $attr, $attrvalues) |
---|
| 484 | |
---|
| 485 | Check attributes C<$attr> of object type C<$otype> allow values C<$attrvalues> |
---|
| 486 | |
---|
| 487 | =cut |
---|
| 488 | |
---|
[861] | 489 | sub check_allowed_values { |
---|
| 490 | my ($self, $otype, $attr, $attrvalues) = @_; |
---|
| 491 | $self->_allowed_values or return 1; |
---|
| 492 | my @values = ref $attrvalues ? @{ $attrvalues } : $attrvalues; |
---|
| 493 | foreach my $value (@values) { |
---|
| 494 | $value or next; |
---|
| 495 | if (my @allowed = $self->obj_attr_allowed_values($otype, $attr)) { |
---|
| 496 | grep { $value eq $_ } @allowed or do { |
---|
| 497 | $self->log(LA_ERR, |
---|
| 498 | "value `%s' is not allow for %s.%s per configuration (allowed_values)", |
---|
| 499 | $value, $otype, $attr |
---|
| 500 | ); |
---|
| 501 | return; |
---|
| 502 | }; |
---|
| 503 | } |
---|
| 504 | } |
---|
| 505 | return 1; |
---|
| 506 | } |
---|
| 507 | |
---|
| 508 | =head2 list_canonical_fields($otype, $for) |
---|
| 509 | |
---|
| 510 | Return the list of supported fields by the database for object type $otype. |
---|
| 511 | |
---|
| 512 | Optionnal $for specify the goal for which the list is requested, only supported |
---|
| 513 | fields will be returns |
---|
| 514 | |
---|
| 515 | =cut |
---|
| 516 | |
---|
| 517 | sub list_canonical_fields { |
---|
| 518 | my ($self, $otype, $for) = @_; |
---|
| 519 | $for ||= 'rw'; |
---|
| 520 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 521 | sort $pclass->_canonical_fields($self, $for); |
---|
| 522 | } |
---|
| 523 | |
---|
| 524 | sub _get_attr_schema { |
---|
| 525 | my ($self, $otype) = @_; |
---|
| 526 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 527 | return $pclass->_get_attr_schema($self); |
---|
| 528 | } |
---|
| 529 | |
---|
[1023] | 530 | =head2 get_attr_schema |
---|
| 531 | |
---|
| 532 | Deprecated |
---|
| 533 | |
---|
| 534 | =cut |
---|
| 535 | |
---|
| 536 | # TODO: kill this |
---|
| 537 | |
---|
[861] | 538 | sub get_attr_schema { |
---|
| 539 | my ($self, $otype, $attribute) = @_; |
---|
| 540 | my $info = $self->_get_attr_schema($otype); |
---|
| 541 | if ($info->{$attribute}) { |
---|
| 542 | return $info->{$attribute}; |
---|
| 543 | } else { |
---|
| 544 | return; |
---|
| 545 | } |
---|
| 546 | } |
---|
| 547 | |
---|
[1023] | 548 | =head2 attribute($otype, $attribute) |
---|
| 549 | |
---|
| 550 | Return attribute object. |
---|
| 551 | |
---|
| 552 | See L<LATMOS::Accounts::Bases::Attribute> |
---|
| 553 | |
---|
| 554 | =cut |
---|
| 555 | |
---|
[861] | 556 | sub attribute { |
---|
| 557 | my ($self, $otype, $attribute) = @_; |
---|
[1002] | 558 | |
---|
| 559 | my $attrinfo; |
---|
| 560 | if (!ref $attribute) { |
---|
| 561 | $attrinfo = $self->get_attr_schema($otype, $attribute) |
---|
| 562 | or return; |
---|
| 563 | $attrinfo->{name} = $attribute; |
---|
| 564 | } else { |
---|
| 565 | $attrinfo = $attribute; |
---|
| 566 | } |
---|
| 567 | |
---|
[861] | 568 | return LATMOS::Accounts::Bases::Attributes->new( |
---|
[1002] | 569 | $attrinfo, |
---|
[861] | 570 | $self, |
---|
| 571 | $otype, |
---|
| 572 | ); |
---|
| 573 | } |
---|
| 574 | |
---|
[1023] | 575 | =head2 delayed_fields |
---|
| 576 | |
---|
| 577 | DEPRECATED |
---|
| 578 | |
---|
| 579 | =cut |
---|
| 580 | |
---|
| 581 | # TODO: kill this |
---|
| 582 | |
---|
[861] | 583 | sub delayed_fields { |
---|
| 584 | my ($self, $otype, $for) = @_; |
---|
| 585 | $self->log(LA_WARN, "calling DEPRECATED delayed_fields " . join(',', |
---|
| 586 | caller)); |
---|
| 587 | $for ||= 'rw'; |
---|
| 588 | my @attrs; |
---|
| 589 | foreach ($self->list_canonical_fields($otype, $for)) { |
---|
| 590 | my $attr = $self->attribute($otype, $_) or next; |
---|
| 591 | $for =~ /w/ && $attr->ro and next; |
---|
| 592 | $attr->delayed or next; |
---|
| 593 | push(@attrs, $_); |
---|
| 594 | } |
---|
| 595 | @attrs |
---|
| 596 | } |
---|
| 597 | |
---|
[1023] | 598 | =head2 ochelper ($otype) |
---|
| 599 | |
---|
| 600 | Return L<LATMOS::Accounts::Bases::OChelper> object |
---|
| 601 | |
---|
| 602 | =cut |
---|
| 603 | |
---|
[861] | 604 | sub ochelper { |
---|
| 605 | my ($self, $otype) = @_; |
---|
| 606 | my $pclass = ucfirst(lc($otype)); |
---|
| 607 | foreach my $class ( |
---|
| 608 | ref($self) . '::OCHelper::' . $pclass, |
---|
| 609 | ref($self) . '::OCHelper', |
---|
| 610 | "LATMOS::Accounts::Bases::OCHelper::$pclass", |
---|
| 611 | 'LATMOS::Accounts::Bases::OCHelper' ) { |
---|
| 612 | eval "require $class;"; |
---|
| 613 | if ($@) { next } # error message ? |
---|
| 614 | my $ochelper = "$class"->new($self, $otype); |
---|
| 615 | return $ochelper; |
---|
| 616 | } |
---|
| 617 | return; |
---|
| 618 | } |
---|
| 619 | |
---|
[74] | 620 | =head2 delete_object($otype, $id) |
---|
| 621 | |
---|
| 622 | Destroy from data base object type $otype having id $id. |
---|
| 623 | |
---|
| 624 | =cut |
---|
| 625 | |
---|
| 626 | sub delete_object { |
---|
| 627 | my ($self, $otype, $id) = @_; |
---|
[488] | 628 | my $obj = $self->get_object($otype, $id) or do { |
---|
| 629 | $self->log(LA_WARN, 'Cannot delete %s/%s: no such object', |
---|
| 630 | $otype, $id); |
---|
| 631 | return; |
---|
| 632 | }; |
---|
| 633 | $self->check_acl($obj, '@DELETE', 'w') or do { |
---|
| 634 | $self->log(LA_WARN, 'permission denied to delete %s/%s', |
---|
| 635 | $otype, $id); |
---|
| 636 | return; |
---|
| 637 | }; |
---|
[1294] | 638 | my $ref = $obj->Iid; |
---|
| 639 | if (my $res = $self->_delete_object($otype, $id)) { |
---|
| 640 | $self->ReportChange($otype, $id, $ref, 'Delete', 'Object deleted'); |
---|
| 641 | return $res; |
---|
| 642 | } |
---|
| 643 | return; |
---|
[488] | 644 | } |
---|
| 645 | |
---|
| 646 | sub _delete_object { |
---|
| 647 | my ($self, $otype, $id) = @_; |
---|
[74] | 648 | my $pclass = $self->_load_obj_class($otype); |
---|
[282] | 649 | $pclass->_delete($self, $id); |
---|
[74] | 650 | } |
---|
| 651 | |
---|
[715] | 652 | =head2 rename_object($otype, $id, $newid) |
---|
| 653 | |
---|
| 654 | Rename an object. |
---|
| 655 | |
---|
| 656 | =cut |
---|
| 657 | |
---|
| 658 | sub rename_object { |
---|
| 659 | my ($self, $otype, $id, $newid) = @_; |
---|
| 660 | |
---|
| 661 | my $obj = $self->get_object($otype, $id) or do { |
---|
[716] | 662 | $self->log(LA_WARN, 'Cannot rename %s/%s: no such object', |
---|
[715] | 663 | $otype, $id); |
---|
| 664 | return; |
---|
| 665 | }; |
---|
[716] | 666 | if (my $chk = (lc($otype) eq 'user' || lc($otype) eq 'group') |
---|
[1113] | 667 | ? LATMOS::Accounts::Utils::check_ug_validity($newid) |
---|
| 668 | : LATMOS::Accounts::Utils::check_oid_validity($newid)) { |
---|
[717] | 669 | $self->log(LA_ERR, "Cannot rename $otype/$id to ID $newid `%s:'", $chk); |
---|
[716] | 670 | return; |
---|
| 671 | } |
---|
[715] | 672 | $self->check_acl($obj, '@DELETE', 'w') && |
---|
[716] | 673 | $self->check_acl($obj, '@CREATE', 'w') or do { |
---|
| 674 | $self->log(LA_WARN, 'permission denied to rename %s/%s', |
---|
[715] | 675 | $otype, $id); |
---|
| 676 | return; |
---|
| 677 | }; |
---|
| 678 | |
---|
[1294] | 679 | my $oldref = $obj->Iid; |
---|
| 680 | |
---|
| 681 | if (my $res = $self->_rename_object($otype, $id, $newid)) { |
---|
| 682 | my $newobj = $self->get_object($otype, $newid) or do { |
---|
| 683 | $self->log(LA_WARN, 'Cannot get object %s/%s: rename failed ?', |
---|
| 684 | $otype, $id); |
---|
| 685 | return; |
---|
| 686 | }; |
---|
| 687 | |
---|
| 688 | $self->ReportChange($otype, $id, $oldref, 'Rename', 'Object rename to %s', $newid); |
---|
| 689 | $newobj->ReportChange('Rename', 'Object renamed from %s', $id); |
---|
| 690 | return $res; |
---|
| 691 | } |
---|
| 692 | return; |
---|
[715] | 693 | } |
---|
| 694 | |
---|
| 695 | sub _rename_object { |
---|
| 696 | my ($self, $otype, $id, $newid) = @_; |
---|
| 697 | my $pclass = $self->_load_obj_class($otype); |
---|
| 698 | $pclass->can('_rename') or do { |
---|
| 699 | $self->log(LA_ERR, 'rename object type %s is unsupported', $otype); |
---|
| 700 | return; |
---|
| 701 | }; |
---|
| 702 | $pclass->_rename($self, $id, $newid); |
---|
| 703 | } |
---|
| 704 | |
---|
[5] | 705 | =head2 load |
---|
| 706 | |
---|
| 707 | Make account base loading data into memory if need. |
---|
| 708 | Should always be called, if database fetch data on the fly |
---|
| 709 | (SQL, LDAP), the function just return True. |
---|
| 710 | |
---|
| 711 | =cut |
---|
| 712 | |
---|
| 713 | sub load { 1 } |
---|
| 714 | |
---|
[3] | 715 | =head2 is_transactionnal |
---|
[2] | 716 | |
---|
[3] | 717 | Return True is the database support commit and rollback |
---|
[2] | 718 | |
---|
[3] | 719 | =cut |
---|
[2] | 720 | |
---|
[3] | 721 | sub is_transactionnal { |
---|
| 722 | my ($self) = @_; |
---|
| 723 | return($self->can('_rollback') && $self->can('_commit')); |
---|
| 724 | } |
---|
[2] | 725 | |
---|
[3] | 726 | =head2 commit |
---|
[2] | 727 | |
---|
[3] | 728 | Save change into the database if change are not done immediately. |
---|
| 729 | This should always be called as you don't know when change are applied. |
---|
[2] | 730 | |
---|
[3] | 731 | Return always true if database does not support any transaction. |
---|
[2] | 732 | |
---|
[3] | 733 | The driver should provides a _commit functions to save data. |
---|
[2] | 734 | |
---|
[3] | 735 | =cut |
---|
[2] | 736 | |
---|
[3] | 737 | sub commit { |
---|
| 738 | my ($self) = @_; |
---|
[210] | 739 | if ($self->can('_commit')) { |
---|
| 740 | la_log(LA_DEBUG, 'Commiting data'); |
---|
[262] | 741 | if (!(my $res = $self->_commit)) { |
---|
[267] | 742 | la_log(LA_ERR, "Commit error on %s", $_->label); |
---|
[262] | 743 | return $res; |
---|
| 744 | } |
---|
[210] | 745 | } |
---|
[861] | 746 | |
---|
| 747 | $self->postcommit(); |
---|
| 748 | |
---|
[264] | 749 | return 1; |
---|
[3] | 750 | } |
---|
[2] | 751 | |
---|
[1023] | 752 | =head2 postcommit |
---|
| 753 | |
---|
| 754 | Run postcommit command |
---|
| 755 | |
---|
| 756 | =cut |
---|
| 757 | |
---|
[861] | 758 | sub postcommit { |
---|
| 759 | my ($self) = @_; |
---|
| 760 | |
---|
| 761 | if ($self->{_options}{postcommit}) { |
---|
| 762 | exec_command($self->{_options}{postcommit}, |
---|
| 763 | { |
---|
| 764 | BASE => $self->label, |
---|
| 765 | BASETYPE => $self->type, |
---|
| 766 | HOOK_TYPE => 'POST', |
---|
| 767 | CONFIG => $self->{_options}{configdir}, |
---|
| 768 | } |
---|
| 769 | ); |
---|
| 770 | } else { |
---|
| 771 | return 1; |
---|
| 772 | } |
---|
| 773 | } |
---|
| 774 | |
---|
[3] | 775 | =head2 rollback |
---|
[2] | 776 | |
---|
[3] | 777 | If database support transaction, rollback changes. Return false |
---|
| 778 | if database does not support. |
---|
[2] | 779 | |
---|
[3] | 780 | If supported, driver should provides a _rollback functions |
---|
[2] | 781 | |
---|
[3] | 782 | =cut |
---|
[2] | 783 | |
---|
[3] | 784 | sub rollback { |
---|
| 785 | my ($self) = @_; |
---|
[210] | 786 | if ($self->can('_rollback')) { |
---|
| 787 | la_log(LA_DEBUG, 'Rolling back data'); |
---|
| 788 | return $self->_rollback; |
---|
| 789 | } else { |
---|
| 790 | return 0; |
---|
| 791 | } |
---|
[3] | 792 | } |
---|
[2] | 793 | |
---|
[49] | 794 | =head2 current_rev |
---|
| 795 | |
---|
| 796 | Return the current revision of the database |
---|
| 797 | |
---|
| 798 | Must be provide by base driver if incremental synchro is supported |
---|
| 799 | |
---|
| 800 | =cut |
---|
| 801 | |
---|
| 802 | sub current_rev { return } |
---|
| 803 | |
---|
| 804 | =head2 list_objects_from_rev($otype, $rev) |
---|
| 805 | |
---|
| 806 | Return the list of UID for object of $otype. |
---|
| 807 | |
---|
| 808 | =cut |
---|
| 809 | |
---|
| 810 | sub list_objects_from_rev { |
---|
| 811 | my ($self, $otype, $rev) = @_; |
---|
| 812 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 813 | if (defined($rev) && $pclass->can('list_from_rev')) { |
---|
| 814 | return $pclass->list_from_rev($self, $rev); |
---|
| 815 | } else { |
---|
| 816 | # no support, return all objects... |
---|
| 817 | return $self->list_objects($otype); |
---|
| 818 | } |
---|
| 819 | } |
---|
| 820 | |
---|
[1023] | 821 | =head2 sync_object_from($srcbase, $otype, $id, %options) |
---|
| 822 | |
---|
| 823 | Sync object type C<$otype> C<$id> from base C<$srcbase> to current base. |
---|
| 824 | |
---|
| 825 | C<%options>: |
---|
| 826 | |
---|
| 827 | =over 4 |
---|
| 828 | |
---|
| 829 | =item nodelete |
---|
| 830 | |
---|
| 831 | Don't delete object if the object synchronize don't exist in source base |
---|
| 832 | |
---|
| 833 | =back |
---|
| 834 | |
---|
| 835 | =cut |
---|
| 836 | |
---|
[532] | 837 | sub sync_object_from { |
---|
| 838 | my ($self, $srcbase, $otype, $id, %options) = @_; |
---|
| 839 | |
---|
| 840 | # is the object type supported by both |
---|
| 841 | foreach ($self, $srcbase) { |
---|
| 842 | $_->is_supported_object($otype) or return ''; |
---|
| 843 | } |
---|
| 844 | |
---|
| 845 | if (my $srcobj = $srcbase->get_object($otype, $id)) { |
---|
| 846 | return $self->sync_object($srcobj, %options); |
---|
| 847 | } elsif (!$options{nodelete}) { |
---|
[540] | 848 | $self->_delete_object($otype, $id) and return 'DELETED'; |
---|
[532] | 849 | } |
---|
| 850 | return; |
---|
| 851 | } |
---|
| 852 | |
---|
[83] | 853 | =head2 sync_object |
---|
| 854 | |
---|
| 855 | Synchronise an object into this base |
---|
| 856 | |
---|
| 857 | =cut |
---|
| 858 | |
---|
| 859 | sub sync_object { |
---|
| 860 | my ($self, $srcobj, %options) = @_; |
---|
[105] | 861 | $self->is_supported_object($srcobj->type) or return ''; |
---|
[83] | 862 | my @fields = $options{attrs} |
---|
| 863 | ? @{ $options{attrs} } |
---|
[103] | 864 | : $self->list_canonical_fields($srcobj->type, 'w'); |
---|
[83] | 865 | my %data; |
---|
| 866 | foreach (@fields) { |
---|
[861] | 867 | # check attribute exists in source: |
---|
| 868 | my $attr = $srcobj->attribute($_) or next; |
---|
[933] | 869 | $attr->readable or next; |
---|
[777] | 870 | if (! $options{onepass}) { |
---|
| 871 | if ($options{firstpass}) { |
---|
[861] | 872 | $attr->delayed and next; |
---|
[777] | 873 | } else { |
---|
[861] | 874 | $attr->delayed or next; |
---|
[777] | 875 | } |
---|
[668] | 876 | } |
---|
[317] | 877 | $data{$_} = $srcobj->_get_c_field($_); |
---|
[83] | 878 | } |
---|
| 879 | if (my $dstobj = $self->get_object($srcobj->type, $srcobj->id)) { |
---|
[861] | 880 | keys %data or return 'SYNCED'; |
---|
| 881 | foreach (keys %data) { |
---|
| 882 | if (!$dstobj->attribute($_) || |
---|
| 883 | $dstobj->attribute($_)->ro) { |
---|
| 884 | delete($data{$_}); |
---|
| 885 | } |
---|
| 886 | } |
---|
[355] | 887 | my $res = $dstobj->_set_c_fields(%data); |
---|
| 888 | if (defined $res) { |
---|
[661] | 889 | return $res ? 'SYNCED' : ''; |
---|
[355] | 890 | } else { |
---|
| 891 | return; |
---|
| 892 | } |
---|
[83] | 893 | } elsif(!$options{nocreate}) { |
---|
[777] | 894 | if ((! $options{firstpass}) && (!$options{onepass})) { |
---|
[775] | 895 | $self->log(LA_ERR, 'This is not first pass, creation wanted but denied'); |
---|
| 896 | return; |
---|
| 897 | } |
---|
[488] | 898 | if ($self->_create_c_object($srcobj->type, $srcobj->id, %data)) { |
---|
[661] | 899 | return 'CREATED' |
---|
[355] | 900 | } else { |
---|
| 901 | return; |
---|
| 902 | } |
---|
[83] | 903 | } else { |
---|
[197] | 904 | # No error, but creation is denied |
---|
| 905 | return 'Creation skipped'; |
---|
[83] | 906 | } |
---|
[105] | 907 | |
---|
| 908 | return; |
---|
[83] | 909 | } |
---|
| 910 | |
---|
[1235] | 911 | =head2 search_objects($otype, @filter) |
---|
[122] | 912 | |
---|
[1235] | 913 | Search object according @filter. @filter is a list |
---|
[122] | 914 | of field/value which should match. |
---|
| 915 | |
---|
| 916 | A default function is provided but each db driver can provide |
---|
| 917 | an optimize version. |
---|
| 918 | |
---|
| 919 | =cut |
---|
| 920 | |
---|
| 921 | sub search_objects { |
---|
[326] | 922 | my ($self, $otype, @filter) = @_; |
---|
[122] | 923 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
[326] | 924 | $pclass->search($self, @filter); |
---|
[122] | 925 | } |
---|
| 926 | |
---|
[1023] | 927 | =head2 attributes_summary($otype, $attr) |
---|
| 928 | |
---|
| 929 | Return couple object id / value for attribute C<$attr> of object type C<$otype> |
---|
| 930 | |
---|
| 931 | This method is designed to be faster than fetching object one by one. |
---|
| 932 | |
---|
| 933 | =cut |
---|
| 934 | |
---|
[257] | 935 | sub attributes_summary { |
---|
| 936 | my ($self, $otype, $attr) = @_; |
---|
| 937 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 938 | $pclass->attributes_summary($self, $attr); |
---|
| 939 | } |
---|
| 940 | |
---|
[1023] | 941 | =head2 find_next_numeric_id($otype, $field, $min, $max) |
---|
| 942 | |
---|
| 943 | Return, if possible, next numeric id available (typically unix user UID). |
---|
| 944 | |
---|
| 945 | =cut |
---|
| 946 | |
---|
[137] | 947 | sub find_next_numeric_id { |
---|
| 948 | my ($self, $otype, $field, $min, $max) = @_; |
---|
| 949 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 950 | $pclass->find_next_numeric_id($self, $field, $min, $max); |
---|
| 951 | } |
---|
| 952 | |
---|
[1023] | 953 | =head2 authenticate_user($username, $passwd) |
---|
| 954 | |
---|
| 955 | Return true if authentication success. |
---|
| 956 | |
---|
| 957 | Must be override by driver if the base have a proper authentication method |
---|
| 958 | |
---|
| 959 | =cut |
---|
| 960 | |
---|
[231] | 961 | sub authenticate_user { |
---|
| 962 | my ($self, $username, $passwd) = @_; |
---|
| 963 | $username or return; |
---|
| 964 | my $uobj = $self->get_object('user', $username) or do { |
---|
| 965 | la_log(LA_ERR, "Cannot authenticate non existing user $username"); |
---|
| 966 | return; |
---|
| 967 | }; |
---|
[671] | 968 | |
---|
[861] | 969 | if ($self->attribute('user', 'exported')) { |
---|
[671] | 970 | if (!$uobj->_get_c_field('exported')) { |
---|
| 971 | la_log(LA_ERR, "User $username found but currently unexported"); |
---|
| 972 | return; |
---|
| 973 | } |
---|
| 974 | } |
---|
| 975 | |
---|
[861] | 976 | if ($uobj->_get_c_field('expired')) { |
---|
| 977 | la_log(LA_ERR, "Account $username has expired (%s)", |
---|
| 978 | $uobj->_get_c_field('expired')); |
---|
| 979 | return; |
---|
[650] | 980 | } |
---|
| 981 | |
---|
| 982 | if ($uobj->_get_c_field('locked')) { |
---|
| 983 | la_log(LA_ERR, "Account $username is currently locked"); |
---|
| 984 | return; |
---|
| 985 | } |
---|
| 986 | |
---|
[937] | 987 | my $password = $uobj->get_field('userPassword') or do { |
---|
[231] | 988 | la_log(LA_ERR, "Cannot authenticate user $username having no passwd"); |
---|
| 989 | return; |
---|
| 990 | }; |
---|
| 991 | if ($password eq crypt($passwd, $password)) { # crypt unix |
---|
[734] | 992 | la_log(LA_NOTICE, "User $username authenticated"); |
---|
[231] | 993 | return 1; |
---|
| 994 | } else { |
---|
| 995 | la_log(LA_ERR, "Cannot authenticate user $username"); |
---|
| 996 | return 0; |
---|
| 997 | } |
---|
| 998 | } |
---|
| 999 | |
---|
[1023] | 1000 | =head2 connect($username, $password) |
---|
| 1001 | |
---|
| 1002 | Authenticate the user and store the username as connected |
---|
| 1003 | |
---|
| 1004 | =cut |
---|
| 1005 | |
---|
[320] | 1006 | sub connect { |
---|
| 1007 | my ($self, $username, $password) = @_; |
---|
| 1008 | my $auth = $self->authenticate_user($username, $password); |
---|
| 1009 | if ($auth) { |
---|
| 1010 | $self->{_user} = $username; |
---|
[477] | 1011 | la_log(LA_DEBUG, "Connected as $username"); |
---|
[320] | 1012 | } |
---|
| 1013 | return $auth; |
---|
| 1014 | } |
---|
| 1015 | |
---|
[1091] | 1016 | =head2 user |
---|
| 1017 | |
---|
| 1018 | Return the current connected username |
---|
| 1019 | |
---|
| 1020 | =cut |
---|
| 1021 | |
---|
| 1022 | sub user { $_[0]->{_user} } |
---|
| 1023 | |
---|
[1023] | 1024 | =head2 check_acl($obj, $attr, $perm) |
---|
| 1025 | |
---|
| 1026 | Return true if connected user have C<$perm> permission on attribute C<$attr> of |
---|
| 1027 | object C<$obj>. |
---|
| 1028 | |
---|
| 1029 | =cut |
---|
| 1030 | |
---|
[316] | 1031 | sub check_acl { |
---|
| 1032 | my ($self, $obj, $attr, $perm) = @_; |
---|
| 1033 | if ($self->{_acls}) { |
---|
[1091] | 1034 | my ($who, $groups) = ($self->user || ''); |
---|
[470] | 1035 | if ($who && (my $uo = $self->get_object('user', $who))) { |
---|
| 1036 | $groups = [ $uo->_get_attributes('memberOf') ]; |
---|
| 1037 | } else { |
---|
| 1038 | $who = ''; |
---|
| 1039 | } |
---|
| 1040 | my $res = $self->{_acls}->check($obj, $attr, $perm, $who, $groups); |
---|
[477] | 1041 | $self->log(LA_INFO, 'permission denied for "%s" to get %s.%s for %s', |
---|
[474] | 1042 | $who, ref $obj ? $obj->id . '(' . $obj->type . ')' : $obj, $attr, $perm) if (!$res); |
---|
[470] | 1043 | return $res; |
---|
[316] | 1044 | } else { |
---|
| 1045 | # No acls, woot |
---|
| 1046 | return 1; |
---|
| 1047 | } |
---|
| 1048 | } |
---|
[320] | 1049 | |
---|
[1023] | 1050 | =head2 text_empty_dump($fh, $otype, $options) |
---|
| 1051 | |
---|
| 1052 | Empty object dump |
---|
| 1053 | |
---|
| 1054 | =cut |
---|
| 1055 | |
---|
[339] | 1056 | sub text_empty_dump { |
---|
| 1057 | my ($self, $fh, $otype, $options) = @_; |
---|
| 1058 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 1059 | $pclass->text_dump($fh, $options, $self); |
---|
| 1060 | } |
---|
| 1061 | |
---|
[3] | 1062 | 1; |
---|
[2] | 1063 | |
---|
[3] | 1064 | __END__ |
---|
[2] | 1065 | |
---|
[3] | 1066 | =head1 SEE ALSO |
---|
[2] | 1067 | |
---|
| 1068 | =head1 AUTHOR |
---|
| 1069 | |
---|
[17] | 1070 | Thauvin Olivier, E<lt>olivier.thauvin@latmos.ipsl.fr<gt> |
---|
[2] | 1071 | |
---|
| 1072 | =head1 COPYRIGHT AND LICENSE |
---|
| 1073 | |
---|
| 1074 | Copyright (C) 2009 by Thauvin Olivier |
---|
| 1075 | |
---|
| 1076 | This library is free software; you can redistribute it and/or modify |
---|
| 1077 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 1078 | at your option, any later version of Perl 5 you may have available. |
---|
| 1079 | |
---|
| 1080 | =cut |
---|