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

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;

our $VERSION = (q$Rev$ =~ /^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 yesno);
@EXPORT_OK = qw(to_ascii exec_command switch_user run_via_sudo 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
}

=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>) {
        $line =~ /^#/ and next;
        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;
        }
    }
    %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 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_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 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

=back

=cut

sub genpassword {
    my (%options) = @_;
    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 && fascist_check($pass) eq 'ok') {
            return $pass;
        }
    }
}

=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