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