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

package LATMOS::Accounts::Utils;
use 5.010000;
use strict;
use warnings;
use Exporter ();
use vars qw(@ISA @EXPORT_OK @EXPORT);
use utf8;
use LATMOS::Accounts::Log;
use File::Temp qw(tempfile);
use Crypt::Cracklib;
use Text::CSV;

our $VERSION = (q$Rev: 2073 $ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Accounts::Utils - Utils functions

=head1 FUNCTIONS

=cut

@ISA = qw(Exporter);
@EXPORT = qw(to_ascii exec_command switch_user run_via_sudo buildLogin loadCSV yesno);
@EXPORT_OK = qw(to_ascii exec_command switch_user run_via_sudo buildLogin loadCSV yesno);

=head2 to_ascii($text)

Replace in C<$text> non ascii caracters from iso-8859-15 table to ascii
equivalent caracter.

=cut

sub to_ascii {
    my ($text) = @_;
    return $text unless(defined($text));
    utf8::decode($text) unless(utf8::is_utf8($text));
    $text =~ s/œ/oe/g;
    $text =~ s/Ê/ae/g;
    $text =~ tr {uà âÀÂÄÀçéÚêëÉÈÊËïîÏÎÞöÎÖÔÌûÛÜć}
                {uaaaAAAceeeeEEEEiiIIoooOOuuUUc};
    $text =~ s/([^[:ascii:]])/_/g;
    $text
} 

=head2 exec_command($command, $env)

Execute C<$command> and redirect output to log system.

C<$env> is a hashref containing environment variable to set, all variables are
prefixed by 'LA_'.

=cut

sub exec_command {
    my ($command, $env) = @_;
    my $rout = undef;
    $rout = \$_[2] if(@_ > 2);

    my @exec = ref $command
        ? (@$command)
        : ($command);
    la_log(LA_DEBUG, 'running command `%s\'', join(' ', @exec));

    pipe(my $rh, my $wh);
    my $pid = fork;
    if (!defined($pid)) {
        la_log(LA_ERR, "Can't launch script: cannot fork");
    } elsif ($pid) {
        # Father
        close($wh);
        my $header;
        while (<$rh>) {
            if ($rout) {
                $$rout .= $_;
            } else {
                chomp;
                if (!$header) {
                    $header = 1;
                    la_log(LA_NOTICE, "exec `%s'", join(' ', @exec));
                }
                la_log(LA_NOTICE, "output: %s", $_);
            }
        }
        waitpid($pid, 0);
        if (my $exitstatus = $?) {
            la_log(LA_ERR, 'command %s exit with status %d',
                join(' ', @exec), $exitstatus);
            return;
        } else {
            return 1;
        }
    } else {
        # Child
        close($rh);
        ( $ENV{LA_MODULE} ) = caller();
        foreach (keys %{ $env || {} }) {
            $ENV{"LA_$_"} = $env->{$_};
        }
        open(STDOUT, ">&=" . fileno($wh));
        open(STDERR, ">&=" . fileno($wh));
        exec(@exec);
        exit($!);
    }
    1
}

sub _parse_line {
    my ( $line, $attributes ) = @_;

    $line =~ /^#/ and return;
    # Empty line are skipped (or space only)
    $line =~ /^\s*$/ and return;
    chomp($line);
    my ($attr, $value) = $line =~ /^\s*(\S+):\s*(.*)\s*$/ or
        die "Malformed input file\n";
    $value =~ s/\s*$//;
    $value =~ s/\\n/\n/g;
    if ($attributes->{$attr}) {
        if (ref $attributes->{$attr}) {
            push(@{ $attributes->{$attr} }, $value);
        } else {
            my $temp = $attributes->{$attr};
            $attributes->{$attr} = [ $temp, $value ];
        }
    } else {
        $attributes->{$attr} = $value eq '' ? undef : $value;
        # Don't remember why this is here
        #$attr eq 'exported' && !defined $attributes->{$attr} and $attributes->{$attr} = 1;
    }
}

=head2 parse_obj_file($handle)

Read file content from C<$handle> and return hash containing parsed attributes

=cut

sub parse_obj_file {
    my ($handle) = @_;

    my $attributes = {};
    while (my $line = <$handle>) {
        _parse_line( $line, $attributes );
    }
    %$attributes
}

=head2 parse_obj_text($text)

=cut

sub parse_obj_text {
    my ( $Text ) = @_;

    my $attributes = {};

    foreach (split(/\n/, $Text)) {
        _parse_line( $_, $attributes );
    }

    %$attributes
}

=head2 dump_read_temp_file($writecb, $readcb)

Create a temporary file, call C<$writecb()> function, run editor and if file get
modified call C<$readcb>.

=cut

sub dump_read_temp_file {
    my ($writecb, $readcb) = @_;

    my ($fh, $filename) = tempfile(CLEANUP => 0);
    $writecb->($fh) or return;
    $fh = undef; # closing file
    my $res;
    
    my @stat = stat($filename);
    while (1) {
        my $cmd = ($ENV{EDITOR} || 'vi') . " $filename";
        warn "Running $cmd\n";
        if (system($cmd) == -1 ) {
            warn "Cannot run editor $!\n";
            last;
        }
        if ((stat($filename))[9] == $stat[9]) {
            warn "No change existing\n";
            last;
        }

        open($fh, '<', $filename) or return;
        $res = $readcb->($fh);
        $fh = undef; # closing again
        $res < 2 and last;
    }
    unlink($filename);
    $res;
}

=head2 loadCSV($fh, $callback, $initcallback)

Parse CVS files and return an array for each parsed line.

C<%options> may contains

=over 4

=item C<initcb> An function call after parsing first line

=item C<cb> A function call for each line

=back

=cut

sub loadCSV {
    my ($fh, %opt) = @_;

    my $csv = Text::CSV->new({
            blank_is_undef => 1,
            binary => 1,
    });

    binmode($fh, ":encoding(UTF-8)");

    # First line contains attribute
    my $columns = $csv->getline( $fh );

    $csv->column_names($columns);

    if ($opt{initcb}) {
        $opt{initcb}->($csv);
    }

    my $all = [];
    my $linecount = 1;
    while ( my $row = $csv->getline_hr( $fh ) ) {
        $linecount++;
        if ($opt{cb}) {
            if (! $opt{cb}->($row, $linecount)) {
                return;
            }
        }
        push(@{ $all }, $row);
    }
    $csv->eof () or do {
        return;
    };

    return $all;
}

=head2 check_oid_validity($name)

Check C<$name> is suitable to be used as object identifier. Return the error
text, undef if no error.

=cut

sub check_oid_validity {
    my ($name) = @_;
    return "leadind space" if ($name =~ /^\s/);
    return "trailing space" if ($name =~ /\s$/);
    return "containing space" if ($name =~ /\s/);

    return;
}

=head2 check_host_validity($name)

Check C<$name> is suitable to be used as nethost identifier. Return the error
text, undef if no error.

=cut

sub check_host_validity {
    my ($name) = @_;
    return "leadind space" if ($name =~ /^\s/);
    return "trailing space" if ($name =~ /\s$/);
    return "containing space" if ($name =~ /\s/);
    return "containing underscore" if ($name =~ /_/);

    return;
}

=head2 check_ug_validity($name)

Check C<$name> is suitable to used as user or group identifier.

=cut

sub check_ug_validity {
    my ($name) = @_;
    return "Empty name is not a valid name !"
        if (!$name);
    return "first caractere must be a-z"
        if ($name !~ /^[a-z]/);
    return "must contain only a-z,0-9"
        if ($name !~ /^[a-z,0-9,_,\-,\.]+$/);
    return "lenght must be < 19 characters"
        if (length($name) >= 20);

    return check_oid_validity($name);
}

=head2 switch_user($runas)

Switch effective id of the process to user named C<$runas>

=cut

sub switch_user {
    my ($runas) = @_;

    if ($< == 0 || $> == 0) {
        my @info = getpwnam($runas) or do {
            warn "Can find user $runas";
            return;
        };
        $> = $info[3];
        return;
    } else {
        warn "we are not root";
    }
}

=head2 run_via_sudo($runas)

Rerun current programme as C<$runas> user using sudo

=cut

sub run_via_sudo {
    my ($runas) = @_;

    my @info = getpwnam($runas) or do {
        warn "Can find user $runas";
        return;
    }; 
    if ($< != $info[3]) {
        exec('sudo', '-u', $runas, $0, @ARGV) or "Can run $!";
    }
}

=head2 genpassword(%options)

Generate a random password, options are:

=over 4

=item length

The minimum password length (default is 6)

=item nonalpha

Include non alpha-numeric caracters

=item syllables

Use a set of syllables instead letter

=item checkpassword

A sub reference to check if generated password is valid

=back

=cut

sub genpassword {
    my (%options) = @_;

    $options{checkpassword} ||= sub {
        my ($cpass) = @_;
        return fascist_check($cpass) eq 'ok';
    };

    my @non_alpha = (qw$; : / ! ( ) [ ] { } + = @ - " ' % * & . ? < >$, ',', '$');
    my @letters = ('a' .. 'z', 'A' .. 'Z', 0 .. 9);

    my @consonants = qw(b d f g j k l m n r s t v x z ch);
    my @vowels = qw(a e i o u ou oi io ia iu);

    $options{length} ||= 8 + int(rand(3));

    while (1) {
        if ($options{syllables}) {
            $options{length} = int($options{length} / 2);
            $options{length} = 3 if ($options{length} < 3);
        } else {
            $options{length} = 6 if ($options{length} < 6);
        }

        my @chars;

        if ($options{nonalpha}) {
            for(0 .. (0 + int(rand(3)))) {
                push(@chars, (@non_alpha[rand(scalar(@non_alpha))]));
            }
        }

        foreach (1 .. ($options{length} - scalar(@chars))) {
            if ($options{syllables}) {
                my $c = @consonants[rand(scalar(@consonants))];
                my $v = @vowels[rand(scalar(@vowels))];
                push(@chars, "$c$v");
            } else {
                push(@chars, (@letters[rand(scalar(@letters))]));
            }
        }


        my $pass = join('', sort { rand() <=> rand() } @chars);
        if (length($pass) >= 6 && $options{checkpassword}->($pass)) {
            return $pass;
        }
    }
}

=head2 Crypt($password, $method)

Build an encrypted password using standard crypt(), $method is the encrypted method to use:

=over 4

=item DES: the old DES method, do not use

=item 1 or md5

=item 5 or sha-256

=item 6 or sha-512

=back

=cut

sub Crypt {
    my ($clearpassword, $method) = @_;

    $method ||= '';
    my $methNumber = {
        'des'     => -1,
        'md5'     =>  1,
        'sha-256' =>  5,
        'sha-512' =>  6,
    }->{lc($method)} || $method || 1;


    if ($methNumber > 0) {
        # Good we're secure
        my @salt_char = (('a' .. 'z'), ('A' .. 'Z'), (0 .. 9), '/', '.');
        my $salt = join('', map { $salt_char[rand(scalar(@salt_char))] } (1 .. 8));

        return crypt($clearpassword, '$' . $methNumber . '$' . $salt);
    } else {
        # Grumpf DES
        my @salt_char = (('a' .. 'z'), ('A' .. 'Z'), (0 .. 9));
        my $salt = join('', map { $salt_char[rand(scalar(@salt_char))] } (1,2));

        return crypt($clearpassword, $salt);
    }
}

=head2 buildLogin([$cb, ] @names)

Try to find a proper login from @names.

Optionnal $cb is a callback to check the solution over exiting data. If return false, another solution is tried

Example:

    buildLogin(sub { $_[0] ? 1 : 0 }, "sn", "givenName")

=cut

sub buildLogin {
    my (@names) = @_;
    my $cb = undef;

    if (ref $names[0]) {
        $cb = shift(@names);
    } else {
        $cb = sub { 1 }; # always validating
    }

    # Cleaning names:
    foreach (@names) {
        $_ ||= '';
        $_ = lc(to_ascii($_));
        s/[^\w]//g;
    }

    @names = grep { $_ } @names;
    my $base = shift(@names) or return;
    my $rest = join('', grep { $_ } @names);

    if ((my $l = length($base)) > 10) {
        my $len = 8;
        while ($len < $l) {
            my $try  = substr($base, 0, $len);
            if ($cb->($try)) {
                return $try;
            }
            $len++;
        }
    } elsif ($cb->($base)) {
        return $base;
    }

    my $try = $base;
    while (my $len = length($try) - length($base) + 1) {
        if ($len > length($rest)) {
            last;
        }
        $try = $base . substr($rest, 0, $len);
        if ($cb->($try)) {
            return $try;
        }
    }
    return;
}

=head2 yesno($value, $default)

Check is a paramter mean yes or no

=cut

sub yesno {
    my ($value, $default) = @_;

    if ($value =~ /^(yes|1|true)$/i) {
        return 1;
    }
    if ($value =~ /^(no|0|false)$/i) {
        return 0;
    }
    if ($value =~ /^\d+$/ and $value != 0) {
        return 1;
    }
    return $default || $value;
}

1;

__END__

=head1 SEE ALSO

L<sudo>

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@aerov.jussieu.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut