[5] | 1 | package LATMOS::Accounts::Bases::Unix; |
---|
| 2 | |
---|
| 3 | use 5.010000; |
---|
| 4 | use strict; |
---|
| 5 | use warnings; |
---|
| 6 | |
---|
| 7 | use base qw(LATMOS::Accounts::Bases); |
---|
[260] | 8 | use LATMOS::Accounts::Log; |
---|
[815] | 9 | use Fcntl qw(:flock); |
---|
[1123] | 10 | use Encode; |
---|
[5] | 11 | |
---|
| 12 | our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0]; |
---|
| 13 | |
---|
| 14 | =head1 NAME |
---|
| 15 | |
---|
| 16 | LATMOS::Ad - Perl extension for blah blah blah |
---|
| 17 | |
---|
| 18 | =head1 SYNOPSIS |
---|
| 19 | |
---|
| 20 | use LATMOS::Accounts::Bases; |
---|
| 21 | my $base = LATMOS::Accounts::Bases->new('unix'); |
---|
| 22 | ... |
---|
| 23 | |
---|
| 24 | =head1 DESCRIPTION |
---|
| 25 | |
---|
| 26 | Account base access over standard unix file format. |
---|
| 27 | |
---|
| 28 | =head1 FUNCTIONS |
---|
| 29 | |
---|
| 30 | =cut |
---|
| 31 | |
---|
[1071] | 32 | =head2 new(%config) |
---|
[5] | 33 | |
---|
| 34 | Create a new LATMOS::Ad object for windows AD $domain. |
---|
| 35 | |
---|
| 36 | domain / server: either the Ad domain or directly the server |
---|
| 37 | |
---|
| 38 | ldap_args is an optionnal list of arguments to pass to L<Net::LDAP>. |
---|
| 39 | |
---|
| 40 | =cut |
---|
| 41 | |
---|
| 42 | sub new { |
---|
[1071] | 43 | my ($class, %config) = @_; |
---|
[5] | 44 | |
---|
| 45 | my $base = { |
---|
| 46 | # are we using shadow, default to yes |
---|
[1071] | 47 | use_shadow => (defined($config{use_shadow}) ? $config{use_shadow} : 1), |
---|
| 48 | min_gid => $config{min_gid}, |
---|
| 49 | min_uid => $config{min_uid}, |
---|
| 50 | nis_overflow => ($config{nis_overflow} || ''), |
---|
[5] | 51 | users => {}, |
---|
| 52 | groups => {}, |
---|
| 53 | }; |
---|
| 54 | |
---|
[861] | 55 | foreach (qw(passwd shadow group gshadow)) { |
---|
[1071] | 56 | if ($config{$_}) { |
---|
| 57 | $base->{$_} = $config{$_}; |
---|
| 58 | } elsif ($config{directory}) { |
---|
| 59 | $base->{$_} = $config{directory} . '/' . $_; |
---|
[861] | 60 | } else { |
---|
| 61 | $base->{$_} = "/etc/$_"; |
---|
| 62 | } |
---|
| 63 | } |
---|
[5] | 64 | |
---|
[13] | 65 | |
---|
[861] | 66 | bless($base, $class); |
---|
[13] | 67 | } |
---|
| 68 | |
---|
[5] | 69 | my @password_fields = qw(account password uid gid gecos home shell); |
---|
| 70 | my @shadow_fields = qw(account spassword last_changed before_ch after_ch exp_warn exp_disable disable res); |
---|
| 71 | my @group_fields = qw(group_name passwd gid user_list); |
---|
| 72 | my @gshadow_fields = qw(group_name spassword unknown suser_list); |
---|
| 73 | |
---|
| 74 | # All UNIX account file are colon separated field |
---|
| 75 | # This function factorize open/read/split fields |
---|
| 76 | |
---|
| 77 | sub _load_unix_file { |
---|
| 78 | my ($self, $file, $callback) = @_; |
---|
[1123] | 79 | my $enc = find_encoding($self->config('encoding') || 'iso-8859-14') |
---|
| 80 | or do { |
---|
| 81 | $self->log(LA_ERROR, "Cannot find encoding %s", $self->config('encoding') || 'iso-8859-15'); |
---|
| 82 | return; |
---|
| 83 | }; |
---|
[260] | 84 | open(my $handle, '<', $file) or do { |
---|
[792] | 85 | $self->log(LA_ERR, "Cannot open unix file `%s' for reading (%s)", $file, $!); |
---|
[260] | 86 | return; |
---|
| 87 | }; |
---|
[792] | 88 | $self->log(LA_DEBUG, "Reading file $file"); |
---|
[815] | 89 | flock($handle, LOCK_EX); |
---|
[5] | 90 | while (my $line = <$handle>) { |
---|
| 91 | chomp($line); |
---|
[1123] | 92 | $line = encode('utf-8', $line); |
---|
[5] | 93 | my @ch = split(':', $line); |
---|
| 94 | $callback->(@ch); |
---|
| 95 | } |
---|
| 96 | close($handle); |
---|
| 97 | return 1; |
---|
| 98 | } |
---|
| 99 | |
---|
| 100 | =head2 load |
---|
| 101 | |
---|
| 102 | Read file and load data into memory |
---|
| 103 | |
---|
| 104 | =cut |
---|
| 105 | |
---|
| 106 | sub load { |
---|
| 107 | my ($self) = @_; |
---|
[792] | 108 | |
---|
| 109 | # If already loaded, just say ok ! |
---|
| 110 | $self->{_loaded} and return 1; |
---|
[5] | 111 | |
---|
| 112 | $self->_load_unix_file( |
---|
| 113 | $self->{passwd}, |
---|
| 114 | sub { |
---|
| 115 | my @ch = @_; |
---|
[48] | 116 | my $user = $ch[0] or return; |
---|
[5] | 117 | # TODO add check ? |
---|
| 118 | foreach (@password_fields) { |
---|
| 119 | $self->{users}{$user}{$_} = shift(@ch); |
---|
| 120 | } |
---|
[185] | 121 | if ($self->{users}{$user}{password} =~ /^!!/) { |
---|
| 122 | $self->{users}{$user}{password} =~ s/^!!//; |
---|
| 123 | $self->{users}{$user}{locked} = 1; |
---|
| 124 | } |
---|
[459] | 125 | $self->{users}{$user}{shell} ||= ''; |
---|
[185] | 126 | $self->{users}{$user}{shell} =~ s/^-//; |
---|
[5] | 127 | }, |
---|
[10] | 128 | ) or return; |
---|
[5] | 129 | |
---|
| 130 | $self->_load_unix_file( |
---|
| 131 | $self->{group}, |
---|
| 132 | sub { |
---|
| 133 | my @ch = @_; |
---|
[646] | 134 | my $group = $ch[0]; |
---|
[597] | 135 | |
---|
[646] | 136 | foreach (@group_fields) { |
---|
| 137 | $self->{groups}{$group}{$_} = shift(@ch); |
---|
| 138 | } |
---|
[597] | 139 | |
---|
[5] | 140 | # split user in the group |
---|
[58] | 141 | foreach (split(',', ($self->{groups}{$group}{'user_list'} || ''))) { |
---|
[5] | 142 | $self->{groups}{$group}{'users'}{$_} = 1; |
---|
| 143 | } |
---|
| 144 | } |
---|
| 145 | ) or return; |
---|
| 146 | |
---|
[646] | 147 | # Post processing group for split group because nis |
---|
| 148 | foreach my $group (keys %{$self->{groups} || {}}) { |
---|
| 149 | if (my ($realgroup) = $group =~ /(.*)_\d\d$/) { |
---|
| 150 | if (exists($self->{groups}{$realgroup}) && |
---|
| 151 | $self->{groups}{$realgroup}{gid} == $self->{groups}{$group}{gid}) { |
---|
| 152 | # for sure, it's the same |
---|
| 153 | foreach (keys %{$self->{groups}{$group}{'users'} || {}}) { |
---|
| 154 | $self->{groups}{$realgroup}{'users'}{$_} = 1; |
---|
| 155 | } |
---|
| 156 | delete($self->{groups}{$group}); |
---|
| 157 | } |
---|
| 158 | } |
---|
| 159 | } |
---|
| 160 | |
---|
[5] | 161 | # using shadow ? then reading shadow file |
---|
| 162 | if ($self->{use_shadow}) { |
---|
[32] | 163 | |
---|
[5] | 164 | $self->_load_unix_file( |
---|
| 165 | $self->{shadow}, |
---|
| 166 | sub { |
---|
| 167 | my @ch = @_; |
---|
| 168 | my $user = $ch[0]; |
---|
| 169 | foreach (@shadow_fields) { |
---|
| 170 | $self->{users}{$user}{$_} = shift(@ch); |
---|
| 171 | } |
---|
[185] | 172 | if ($self->{users}{$user}{spassword} =~ /^!!/) { |
---|
| 173 | $self->{users}{$user}{spassword} =~ s/^!!//; |
---|
| 174 | $self->{users}{$user}{locked} = 1; |
---|
| 175 | } |
---|
[5] | 176 | } |
---|
| 177 | ) or return; |
---|
| 178 | |
---|
| 179 | $self->_load_unix_file( |
---|
| 180 | $self->{gshadow}, |
---|
| 181 | sub { |
---|
| 182 | my @ch = @_; |
---|
| 183 | my $group = $ch[0]; |
---|
| 184 | # TODO add check ? |
---|
| 185 | foreach (@gshadow_fields) { |
---|
| 186 | $self->{groups}{$group}{$_} = shift(@ch); |
---|
| 187 | } |
---|
| 188 | # split user in the group |
---|
[58] | 189 | foreach (split(',', $self->{groups}{$group}{'suser_list'} || '')) { |
---|
[5] | 190 | $self->{groups}{$group}{'susers'}{$_} = 1; |
---|
| 191 | } |
---|
| 192 | } |
---|
| 193 | ) or return; |
---|
| 194 | |
---|
| 195 | } # use shadow ? |
---|
[32] | 196 | |
---|
[792] | 197 | $self->{_loaded} = 1; |
---|
| 198 | |
---|
[32] | 199 | 1; |
---|
[5] | 200 | } |
---|
| 201 | |
---|
[10] | 202 | sub _save_unix_file { |
---|
| 203 | my ($self, $file, @data) = @_; |
---|
[1123] | 204 | my $enc = find_encoding($self->config('encoding') || 'iso-8859-14') |
---|
| 205 | or do { |
---|
| 206 | $self->log(LA_ERROR, "Cannot find encoding %s", $self->config('encoding') || 'iso-8859-15'); |
---|
| 207 | return; |
---|
| 208 | }; |
---|
[815] | 209 | open(my $handle, '>>', $file) or do { |
---|
[260] | 210 | la_log(LA_ERR, "Cannot open unix file `%s' for writing (%s)", $file, $!); |
---|
| 211 | return; |
---|
| 212 | }; |
---|
[815] | 213 | flock($handle, LOCK_EX); |
---|
| 214 | truncate($handle, 0); |
---|
[10] | 215 | foreach my $line (@data) { |
---|
[1123] | 216 | my $string = join(':', map { my $f = $_; $f =~ s/:/;/g; $f } map { defined($_) ? $_ : '' } @$line) . "\n"; |
---|
| 217 | $string = decode('utf8', $string); |
---|
| 218 | print $handle $string; |
---|
[10] | 219 | } |
---|
| 220 | close($handle); |
---|
[784] | 221 | $self->log(LA_INFO, $file . " saved"); |
---|
[10] | 222 | return 1; |
---|
| 223 | } |
---|
| 224 | |
---|
[268] | 225 | sub _commit { |
---|
[10] | 226 | my ($self) = @_; |
---|
| 227 | |
---|
| 228 | $self->_save_unix_file( |
---|
| 229 | $self->{passwd}, |
---|
| 230 | map {[ |
---|
| 231 | $_, |
---|
[185] | 232 | ($self->{users}{$_}{locked} |
---|
| 233 | ? '!!' . ($self->{users}{$_}{password} || '') |
---|
| 234 | : ($self->{users}{$_}{password} || 'x')), # No empty pass !! |
---|
[10] | 235 | $self->{users}{$_}{uid}, |
---|
| 236 | $self->{users}{$_}{gid}, |
---|
[366] | 237 | $self->{users}{$_}{gecos} || '', |
---|
| 238 | $self->{users}{$_}{home} || '/dev/null', |
---|
| 239 | ($self->{users}{$_}{locked} ? '-' : '') . ($self->{users}{$_}{shell} |
---|
| 240 | || '/bin/false'), |
---|
[16] | 241 | ]} sort { $self->{users}{$a}{uid} <=> $self->{users}{$b}{uid} } keys %{$self->{users}} |
---|
[10] | 242 | ) or return; |
---|
| 243 | |
---|
[597] | 244 | my @grouplines = (); |
---|
| 245 | foreach ( |
---|
| 246 | sort { $self->{groups}{$a}{gid} <=> $self->{groups}{$b}{gid} } |
---|
| 247 | keys %{$self->{groups}}) { |
---|
| 248 | my @gline = ($_, $self->{groups}{$_}{password} || 'x', |
---|
| 249 | $self->{groups}{$_}{gid}, |
---|
| 250 | join(',', sort keys %{$self->{groups}{$_}{users} || {}}), |
---|
| 251 | ); |
---|
| 252 | if (length(join(':', @gline)) >= 1023) { |
---|
| 253 | $self->{nis_overflow} ||= ''; |
---|
| 254 | if ($self->{nis_overflow} eq 'kill') { |
---|
| 255 | $gline[3] = 'LINE_TOO_LONG'; |
---|
| 256 | } elsif ($self->{nis_overflow} eq 'truncate') { |
---|
| 257 | my $len = length(join(':', @gline[0 .. 2])) + 1; |
---|
| 258 | my @users = sort keys %{$self->{groups}{$_}{users} || {}}; |
---|
| 259 | while (@users && $len + length(join(',', @users)) >= 1023) { |
---|
| 260 | pop(@users); |
---|
| 261 | } |
---|
| 262 | $gline[3] = join(',', @users); |
---|
| 263 | } elsif($self->{nis_overflow} eq 'split') { |
---|
| 264 | my @users = sort keys %{$self->{groups}{$_}{users} || {}}; |
---|
| 265 | my $count = 0; |
---|
| 266 | my @nextusers; |
---|
| 267 | while (my $u = shift(@users)) { |
---|
[649] | 268 | my $needflush = 0; |
---|
| 269 | if (length(join(':', @gline[0 .. 2])) + 1 + |
---|
| 270 | length(join(',', (@nextusers, $u))) >= 1023) { |
---|
| 271 | unshift(@users, $u); |
---|
| 272 | $needflush = 1; |
---|
| 273 | } else { |
---|
| 274 | push(@nextusers, $u); |
---|
| 275 | } |
---|
| 276 | if (!@users || $needflush) { |
---|
[597] | 277 | push(@grouplines, [ |
---|
| 278 | $gline[0] . ($count ? sprintf('_%02d', $count) :''), |
---|
| 279 | $gline[1], |
---|
| 280 | $gline[2], |
---|
| 281 | join(',', @nextusers) ] |
---|
| 282 | ); |
---|
| 283 | @nextusers = (); $count++; |
---|
| 284 | } |
---|
| 285 | } |
---|
| 286 | next; |
---|
| 287 | } |
---|
| 288 | } |
---|
| 289 | push(@grouplines, \@gline); |
---|
| 290 | } |
---|
[10] | 291 | $self->_save_unix_file( |
---|
| 292 | $self->{group}, |
---|
[597] | 293 | @grouplines, |
---|
[10] | 294 | ) or return; |
---|
| 295 | |
---|
| 296 | if ($self->{use_shadow}) { |
---|
| 297 | |
---|
| 298 | $self->_save_unix_file( |
---|
| 299 | $self->{shadow}, |
---|
| 300 | map {[ |
---|
| 301 | $_, |
---|
[185] | 302 | ($self->{users}{$_}{locked} |
---|
| 303 | ? '!!' . ($self->{users}{$_}{spassword} || '') |
---|
| 304 | : $self->{users}{$_}{spassword} || 'x'), |
---|
[10] | 305 | $self->{users}{$_}{last_changed}, |
---|
| 306 | $self->{users}{$_}{before_ch}, |
---|
| 307 | $self->{users}{$_}{after_ch}, |
---|
| 308 | $self->{users}{$_}{exp_warn}, |
---|
| 309 | $self->{users}{$_}{exp_disable}, |
---|
| 310 | $self->{users}{$_}{disable}, |
---|
| 311 | $self->{users}{$_}{res}, |
---|
[16] | 312 | ]} sort { $self->{users}{$a}{uid} <=> $self->{users}{$b}{uid} } keys %{$self->{users}} |
---|
[10] | 313 | ) or return; |
---|
| 314 | |
---|
| 315 | |
---|
| 316 | $self->_save_unix_file( |
---|
| 317 | $self->{gshadow}, |
---|
| 318 | map {[ |
---|
| 319 | $_, |
---|
| 320 | $self->{groups}{$_}{spassword} || 'x', |
---|
| 321 | $self->{groups}{$_}{unknown}, |
---|
| 322 | join(',', keys %{$self->{groups}{$_}{susers} || {}}), |
---|
[16] | 323 | ]} sort { $self->{groups}{$a}{gid} <=> $self->{groups}{$b}{gid} } keys %{$self->{groups}} |
---|
[10] | 324 | ) or return; |
---|
| 325 | |
---|
| 326 | } # If use shadow |
---|
| 327 | |
---|
| 328 | 1 |
---|
| 329 | } |
---|
| 330 | |
---|
[32] | 331 | sub list_objects { |
---|
| 332 | my ($self, $otype) = @_; |
---|
| 333 | |
---|
| 334 | # objects are store into sub ref: |
---|
| 335 | my $internal_obj = { |
---|
| 336 | user => 'users', |
---|
| 337 | group => 'groups', |
---|
| 338 | }->{$otype}; |
---|
[72] | 339 | my @obj = sort keys %{$self->{$internal_obj} || {} }; |
---|
| 340 | for ($otype) { |
---|
| 341 | /^user$/ and |
---|
| 342 | return grep { $self->{$internal_obj}{$_}{uid} >= ($self->{min_uid} || 0) } @obj; |
---|
| 343 | /^group$/ and |
---|
| 344 | return grep { $self->{$internal_obj}{$_}{gid} >= ($self->{min_gid} || 0) } @obj; |
---|
| 345 | } |
---|
[32] | 346 | } |
---|
| 347 | |
---|
[16] | 348 | sub create_object { |
---|
| 349 | my ($self, $otype, $id, %data) = @_; |
---|
| 350 | |
---|
[18] | 351 | # objects are store into sub ref: |
---|
[16] | 352 | my $internal_obj = { |
---|
| 353 | user => 'users', |
---|
| 354 | group => 'groups', |
---|
| 355 | }->{$otype}; |
---|
[72] | 356 | for ($otype) { |
---|
| 357 | /^user$/ && !defined($data{uid}) && !defined($data{gid}) and return; |
---|
| 358 | /^group$/ && !defined($data{gid}) and return; |
---|
| 359 | } |
---|
[16] | 360 | |
---|
| 361 | if ($self->{$internal_obj}{$id}) { return }; |
---|
[72] | 362 | $self->{$internal_obj}{$id} = { |
---|
| 363 | account => $id, |
---|
| 364 | uid => $data{uid}, |
---|
| 365 | gid => $data{gid}, |
---|
| 366 | }; |
---|
[16] | 367 | my $obj = $self->get_object($otype, $id) or return; |
---|
| 368 | $obj->set_fields(%data); |
---|
| 369 | $obj |
---|
| 370 | } |
---|
| 371 | |
---|
[488] | 372 | sub _delete_object { |
---|
[74] | 373 | my ($self, $otype, $id, %data) = @_; |
---|
| 374 | |
---|
| 375 | # objects are store into sub ref: |
---|
| 376 | my $internal_obj = { |
---|
| 377 | user => 'users', |
---|
| 378 | group => 'groups', |
---|
| 379 | }->{$otype}; |
---|
| 380 | delete $self->{$internal_obj}{$id}; |
---|
| 381 | 1 |
---|
| 382 | } |
---|
| 383 | |
---|
[715] | 384 | sub _rename_object { |
---|
| 385 | my ($self, $otype, $id, $newid) = @_; |
---|
| 386 | my $internal_obj = { |
---|
| 387 | user => 'users', |
---|
| 388 | group => 'groups', |
---|
| 389 | }->{$otype}; |
---|
| 390 | |
---|
| 391 | if (exists($self->{$internal_obj}{$newid})) { |
---|
| 392 | $self->log(LA_ERR, 'cannot rename %s/%s, %s already exists', |
---|
| 393 | $otype, $id, $newid); |
---|
| 394 | return; |
---|
| 395 | } |
---|
| 396 | |
---|
| 397 | $self->{$internal_obj}{$newid} = $self->{$internal_obj}{$id}; |
---|
| 398 | delete($self->{$internal_obj}{$id}); |
---|
| 399 | |
---|
| 400 | 1 |
---|
| 401 | } |
---|
| 402 | |
---|
[5] | 403 | 1; |
---|
| 404 | |
---|
| 405 | __END__ |
---|
| 406 | |
---|
| 407 | =head1 SEE ALSO |
---|
| 408 | |
---|
| 409 | =head1 AUTHOR |
---|
| 410 | |
---|
| 411 | Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt> |
---|
| 412 | |
---|
| 413 | =head1 COPYRIGHT AND LICENSE |
---|
| 414 | |
---|
| 415 | Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS |
---|
| 416 | |
---|
| 417 | This library is free software; you can redistribute it and/or modify |
---|
| 418 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 419 | at your option, any later version of Perl 5 you may have available. |
---|
| 420 | |
---|
| 421 | |
---|
| 422 | =cut |
---|