package Fripost::Schema::Misc; =head1 NAME Misc.pm - =cut use 5.010_000; use strict; use warnings; use utf8; use Exporter 'import'; our @EXPORT_OK = qw /concat get_perms explode must_attrs email_valid/; use Email::Valid; use Net::IDN::Encode; use Encode; # Let the first argument, if defined, intersperse the other arguments. sub concat { my $concat = shift; if (defined $concat) { return join ($concat, @_); } else { return [ @_ ]; } } # The reverse of 'concat': takes a single line, and split it along # "concat", if defined. Returns an array reference in any case. sub explode { my $concat = shift; my $out; if (defined $concat) { $out = [ split /$concat/, $_[0] ]; } else { $out = [ @_ ]; } [ grep { !/^\s*$/ } @$out ]; } # This subroutine displays the access that the given DN has on the entry. # Possible values are : # - '': no rights # - a: can create aliases # - l: can create lists # - al: can create aliases & lists # - o: owner # - p: postmaster sub get_perms { my ($entry, $dn) = @_; my $perms = ''; $perms .= 'a' if grep { $dn eq $_ or (split /,/,$dn,2)[1] eq $_ } $entry->get_value ('fripostCanCreateAlias'); $perms .= 'l' if grep { $dn eq $_ or (split /,/,$dn,2)[1] eq $_ } $entry->get_value ('fripostCanCreateList'); $perms = 'o' if grep { $dn eq $_ } $entry->get_value('fripostOwner'); $perms = 'p' if grep { $dn eq $_ } $entry->get_value('fripostPostmaster'); return $perms; } # "&must_att $h qw/a b c .../" ensures that attributes a b c... are all # defined in the hash reference. sub must_attrs { my $h = shift; foreach (@_) { die 'Missing attribute: ‘'.$_."’\n" unless defined $h->{$_} and (ref $h->{$_} eq 'ARRAY' ? @{$h->{$_}} : $h->{$_} ne '') } } # Ensure that the first argument is a valid email. Can also be used to # check the validity of domains using the '-prefix' option. # '-exact' forces the input to be a bare email, ("name " is not # allowed). sub email_valid { my $in = shift; my %options = @_; my $i = $in; $i =~ s/^[^<>]+\s<([^>]+)>/$1/; my $mesg = $options{'-error'} // "Invalid e-mail"; $in = $options{'-prefix'}.$i if defined $options{'-prefix'}; Encode::_utf8_on($in); Encode::_utf8_on($i); $in = Net::IDN::Encode::email_to_ascii($in); my $addr = Email::Valid::->address( -address => $in, -tldcheck => 1, -fqdn => 1 ); my $match = defined $addr; $match &&= $addr eq $in if $options{'-exact'}; die $mesg." ‘".$i."’\n" unless $match; $addr =~ s/^$options{'-prefix'}// if defined $options{'-prefix'}; return $addr; } =head1 AUTHOR Guilhem Moulin C<< >> =head1 COPYRIGHT Copyright 2012 Guilhem Moulin. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; __END__