source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Utils.pm @ 1985

Last change on this file since 1985 was 1985, checked in by nanardon, 7 years ago

Add tools to create multiple object from csv file

  • Property svn:keywords set to Id Rev
File size: 10.2 KB
Line 
1package LATMOS::Accounts::Utils;
2use 5.010000;
3use strict;
4use warnings;
5use Exporter ();
6use vars qw(@ISA @EXPORT_OK @EXPORT);
7use utf8;
8use LATMOS::Accounts::Log;
9use File::Temp qw(tempfile);
10use Crypt::Cracklib;
11use Text::CSV;
12
13our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];
14
15=head1 NAME
16
17LATMOS::Accounts::Utils - Utils functions
18
19=head1 FUNCTIONS
20
21=cut
22
23@ISA = qw(Exporter);
24@EXPORT = qw(to_ascii exec_command switch_user run_via_sudo buildLogin loadCSV yesno);
25@EXPORT_OK = qw(to_ascii exec_command switch_user run_via_sudo buildLogin loadCSV yesno);
26
27=head2 to_ascii($text)
28
29Replace in C<$text> non ascii caracters from iso-8859-15 table to ascii
30equivalent caracter.
31
32=cut
33
34sub to_ascii {
35    my ($text) = @_;
36    return $text unless(defined($text));
37    utf8::decode($text) unless(utf8::is_utf8($text));
38    $text =~ s/œ/oe/g;
39    $text =~ s/Ê/ae/g;
40    $text =~ tr {uàâÀÂÄÀçéÚêëÉÈÊËïîÏÎÞöÎÖÔÌûÛÜć}
41                {uaaaAAAceeeeEEEEiiIIoooOOuuUUc};
42    $text =~ s/([^[:ascii:]])/_/g;
43    $text
44} 
45
46=head2 exec_command($command, $env)
47
48Execute C<$command> and redirect output to log system.
49
50C<$env> is a hashref containing environment variable to set, all variables are
51prefixed by 'LA_'.
52
53=cut
54
55sub exec_command {
56    my ($command, $env) = @_;
57    my $rout = undef;
58    $rout = \$_[2] if(@_ > 2);
59
60    my @exec = ref $command
61        ? (@$command)
62        : ($command);
63    la_log(LA_DEBUG, 'running command `%s\'', join(' ', @exec));
64
65    pipe(my $rh, my $wh);
66    my $pid = fork;
67    if (!defined($pid)) {
68        la_log(LA_ERR, "Can't launch script: cannot fork");
69    } elsif ($pid) {
70        # Father
71        close($wh);
72        my $header;
73        while (<$rh>) {
74            if ($rout) {
75                $$rout .= $_;
76            } else {
77                chomp;
78                if (!$header) {
79                    $header = 1;
80                    la_log(LA_NOTICE, "exec `%s'", join(' ', @exec));
81                }
82                la_log(LA_NOTICE, "output: %s", $_);
83            }
84        }
85        waitpid($pid, 0);
86        if (my $exitstatus = $?) {
87            la_log(LA_ERR, 'command %s exit with status %d',
88                join(' ', @exec), $exitstatus);
89            return;
90        } else {
91            return 1;
92        }
93    } else {
94        # Child
95        close($rh);
96        ( $ENV{LA_MODULE} ) = caller();
97        foreach (keys %{ $env || {} }) {
98            $ENV{"LA_$_"} = $env->{$_};
99        }
100        open(STDOUT, ">&=" . fileno($wh));
101        open(STDERR, ">&=" . fileno($wh));
102        exec(@exec);
103        exit($!);
104    }
105    1
106}
107
108=head2 parse_obj_file($handle)
109
110Read file content from C<$handle> and return hash containing parsed attributes
111
112=cut
113
114sub parse_obj_file {
115    my ($handle) = @_;
116
117    my %attributes;
118    while (my $line = <$handle>) {
119        $line =~ /^#/ and next;
120        chomp($line);
121        my ($attr, $value) = $line =~ /^\s*(\S+):\s*(.*)\s*$/ or
122            die "Malformed input file\n";
123        $value =~ s/\s*$//;
124        $value =~ s/\\n/\n/g;
125        if ($attributes{$attr}) {
126            if (ref $attributes{$attr}) {
127                push(@{ $attributes{$attr} }, $value);
128            } else {
129                my $temp = $attributes{$attr};
130                $attributes{$attr} = [ $temp, $value ];
131            }
132        } else {
133            $attributes{$attr} = $value eq '' ? undef : $value;
134            # Don't remember why this is here
135            #$attr eq 'exported' && !defined $attributes{$attr} and $attributes{$attr} = 1;
136        }
137    }
138    %attributes
139}
140
141=head2 dump_read_temp_file($writecb, $readcb)
142
143Create a temporary file, call C<$writecb()> function, run editor and if file get
144modified call C<$readcb>.
145
146=cut
147
148sub dump_read_temp_file {
149    my ($writecb, $readcb) = @_;
150
151    my ($fh, $filename) = tempfile(CLEANUP => 0);
152    $writecb->($fh) or return;
153    $fh = undef; # closing file
154    my $res;
155   
156    my @stat = stat($filename);
157    while (1) {
158        my $cmd = ($ENV{EDITOR} || 'vi') . " $filename";
159        warn "Running $cmd\n";
160        if (system($cmd) == -1 ) {
161            warn "Cannot run editor $!\n";
162            last;
163        }
164        if ((stat($filename))[9] == $stat[9]) {
165            warn "No change existing\n";
166            last;
167        }
168
169        open($fh, '<', $filename) or return;
170        $res = $readcb->($fh);
171        $fh = undef; # closing again
172        $res < 2 and last;
173    }
174    unlink($filename);
175    $res;
176}
177
178=head2 loadCSV($fh, $callback, $initcallback)
179
180Parse CVS files and return an array for each parsed line.
181
182If defined call C<$callback> for parsed line.
183
184C<$initcallback>, if defined, is called just after the first line.
185
186=cut
187
188sub loadCSV {
189    my ($fh, $cb, $initcb) = @_;
190
191    my $csv = Text::CSV->new({
192            blank_is_undef => 1,
193            binary => 1,
194    });
195
196    binmode($fh, ":encoding(UTF-8)");
197
198    # First line contains attribute
199    my $columns = $csv->getline( $fh );
200
201    $csv->column_names($columns);
202
203    if ($initcb) {
204        $initcb->($csv);
205    }
206
207    my $all = [];
208    my $linecount = 1;
209    while ( my $row = $csv->getline_hr( $fh ) ) {
210        $linecount++;
211        if ($cb) {
212            if (! $cb->($row, $linecount)) {
213                return;
214            }
215        }
216        push(@{ $all }, $row);
217    }
218    $csv->eof () or do {
219        return;
220    };
221
222    return $all;
223}
224
225=head2 check_oid_validity($name)
226
227Check C<$name> is suitable to be used as object identifier. Return the error
228text, undef if no error.
229
230=cut
231
232sub check_oid_validity {
233    my ($name) = @_;
234    return "leadind space" if ($name =~ /^\s/);
235    return "trailing space" if ($name =~ /\s$/);
236    return "containing space" if ($name =~ /\s/);
237
238    return;
239}
240
241=head2 check_ug_validity($name)
242
243Check C<$name> is suitable to used as user or group identifier.
244
245=cut
246
247sub check_ug_validity {
248    my ($name) = @_;
249    return "Empty name is not a valid name !"
250        if (!$name);
251    return "first caractere must be a-z"
252        if ($name !~ /^[a-z]/);
253    return "must contain only a-z,0-9"
254        if ($name !~ /^[a-z,0-9,_,\-,\.]+$/);
255
256    return check_oid_validity($name);
257}
258
259=head2 switch_user($runas)
260
261Switch effective id of the process to user named C<$runas>
262
263=cut
264
265sub switch_user {
266    my ($runas) = @_;
267
268    if ($< == 0 || $> == 0) {
269        my @info = getpwnam($runas) or do {
270            warn "Can find user $runas";
271            return;
272        };
273        $> = $info[3];
274        return;
275    } else {
276        warn "we are not root";
277    }
278}
279
280=head2 run_via_sudo($runas)
281
282Rerun current programme as C<$runas> user using sudo
283
284=cut
285
286sub run_via_sudo {
287    my ($runas) = @_;
288
289    my @info = getpwnam($runas) or do {
290        warn "Can find user $runas";
291        return;
292    }; 
293    if ($< != $info[3]) {
294        exec('sudo', '-u', $runas, $0, @ARGV) or "Can run $!";
295    }
296}
297
298=head2 genpassword(%options)
299
300Generate a random password, options are:
301
302=over 4
303
304=item length
305
306The minimum password length (default is 6)
307
308=item nonalpha
309
310Include non alpha-numeric caracters
311
312=item syllables
313
314Use a set of syllables instead letter
315
316=back
317
318=cut
319
320sub genpassword {
321    my (%options) = @_;
322    my @non_alpha = (qw$; : / ! ( ) [ ] { } + = @ - " ' % * & . ? < >$, ',', '$');
323    my @letters = ('a' .. 'z', 'A' .. 'Z', 0 .. 9);
324
325    my @consonants = qw(b d f g j k l m n r s t v x z ch);
326    my @vowels = qw(a e i o u ou oi io ia iu);
327
328    $options{length} ||= 8 + int(rand(3));
329
330    while (1) {
331        if ($options{syllables}) {
332            $options{length} = int($options{length} / 2);
333            $options{length} = 3 if ($options{length} < 3);
334        } else {
335            $options{length} = 6 if ($options{length} < 6);
336        }
337
338        my @chars;
339
340        if ($options{nonalpha}) {
341            for(0 .. (0 + int(rand(3)))) {
342                push(@chars, (@non_alpha[rand(scalar(@non_alpha))]));
343            }
344        }
345
346        foreach (1 .. ($options{length} - scalar(@chars))) {
347            if ($options{syllables}) {
348                my $c = @consonants[rand(scalar(@consonants))];
349                my $v = @vowels[rand(scalar(@vowels))];
350                push(@chars, "$c$v");
351            } else {
352                push(@chars, (@letters[rand(scalar(@letters))]));
353            }
354        }
355
356
357        my $pass = join('', sort { rand() <=> rand() } @chars);
358        if (length($pass) >= 6 && fascist_check($pass) eq 'ok') {
359            return $pass;
360        }
361    }
362}
363
364=head2 buildLogin([$cb, ] @names)
365
366Try to find a proper login from @names.
367
368Optionnal $cb is a callback to check the solution over exiting data. If return false, another solution is tried
369
370Example:
371
372    buildLogin(sub { $_[0] ? 1 : 0 }, "sn", "givenName")
373
374=cut
375
376sub buildLogin {
377    my (@names) = @_;
378    my $cb = undef;
379
380    if (ref $names[0]) {
381        $cb = shift(@names);
382    } else {
383        $cb = sub { 1 }; # always validating
384    }
385
386    # Cleaning names:
387    foreach (@names) {
388        $_ ||= '';
389        $_ = lc(to_ascii($_));
390        s/[^\w]//g;
391    }
392
393    @names = grep { $_ } @names;
394    my $base = shift(@names) or return;
395    my $rest = join('', grep { $_ } @names);
396
397    if ((my $l = length($base)) > 10) {
398        my $len = 8;
399        while ($len < $l) {
400            my $try  = substr($base, 0, $len);
401            if ($cb->($try)) {
402                return $try;
403            }
404            $len++;
405        }
406    } elsif ($cb->($base)) {
407        return $base;
408    }
409
410    my $try = $base;
411    while (my $len = length($try) - length($base) + 1) {
412        if ($len > length($rest)) {
413            last;
414        }
415        $try = $base . substr($rest, 0, $len);
416        if ($cb->($try)) {
417            return $try;
418        }
419    }
420    return;
421}
422
423=head2 yesno($value, $default)
424
425Check is a paramter mean yes or no
426
427=cut
428
429sub yesno {
430    my ($value, $default) = @_;
431
432    if ($value =~ /^(yes|1|true)$/i) {
433        return 1;
434    }
435    if ($value =~ /^(no|0|false)$/i) {
436        return 0;
437    }
438    if ($value =~ /^\d+$/ and $value != 0) {
439        return 1;
440    }
441    return $default || $value;
442}
443
4441;
445
446__END__
447
448=head1 SEE ALSO
449
450L<sudo>
451
452=head1 AUTHOR
453
454Olivier Thauvin, E<lt>olivier.thauvin@aerov.jussieu.frE<gt>
455
456=head1 COPYRIGHT AND LICENSE
457
458Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS
459
460This library is free software; you can redistribute it and/or modify
461it under the same terms as Perl itself, either Perl version 5.10.0 or,
462at your option, any later version of Perl 5 you may have available.
463
464=cut
Note: See TracBrowser for help on using the repository browser.