1 files changed, 57 insertions, 22 deletions

diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm
index 59d724f..b3439cc 100644
--- a/lib/Fripost/Schema/Util.pm
+++ b/lib/Fripost/Schema/Util.pm
@@ -15,10 +15,11 @@ use Exporter 'import';
 our @EXPORT_OK = qw /concat get_perms explode
                      must_attrs domain_valid email_valid split_addr dn2mail
                      canonical_dn ldap_explode_dn ldap_error ldap_and_filter
-                     clean_ldap_entry
-                     assert softdie/;
+                     ldap_clean_entry
+                     assert ldap_assert_absent softdie/;
 use Email::Valid;
-use Net::IDN::Encode qw/domain_to_unicode email_to_unicode/;
+use Net::IDN::Encode qw/domain_to_unicode email_to_unicode
+                        domain_to_ascii email_to_ascii/;
 use Net::LDAP::Util;
 use Encode;
 
@@ -89,7 +90,7 @@ sub get_perms {
 sub must_attrs {
     my $h = shift;
     foreach (@_) {
-        die 'Missing attribute: ‘'.$_."’\n"
+        die 'Missing value: ‘'.$_."’\n"
             unless defined $h->{$_} and
                    (ref $h->{$_} eq 'ARRAY' ? @{$h->{$_}} : $h->{$_} ne '')
     }
@@ -110,14 +111,17 @@ sub email_valid {
     $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'};
-    unless ($match) {
+
+    my ($addr, $match);
+    eval {
+        $in = Net::IDN::Encode::email_to_ascii($in);
+        $addr = Email::Valid::->address( -address => $in,
+                                            -tldcheck => 1,
+                                            -fqdn => 1 );
+        $match = defined $addr;
+        $match &&= $addr eq $in if $options{'-exact'};
+    };
+    if ($@ || !$match) {
       return if $options{'-nodie'};
       die $mesg." ‘".$i."’\n";
     }
@@ -157,24 +161,33 @@ sub split_addr {
     my $addr = shift // return;
     my %options = @_;
 
-    $addr =~ /^(.*)\@([^\@]+)$/s;
-    my ($l,$d) = ($1, $2);
-
+    Encode::_utf8_on($addr);
+    my $mesg = $addr =~ /\@/ ? "Invalid e-mail ‘".$addr."’" :
+                               "Invalid domain ‘".$addr."’";
+    my $ret;
     if (defined $options{'-encode'}) {
         my $e = $options{'-encode'};
         if ($e eq 'ascii') {
-            Encode::_utf8_on($d);
-            $d = Net::IDN::Encode::domain_to_ascii($d);
+            eval { $addr = $addr =~ /\@/ ? email_to_ascii($addr)
+                                         : domain_to_ascii($addr);
+            };
+            $ret = $@;
         }
         elsif ($e eq 'unicode') {
-            $d = Net::IDN::Encode::domain_to_unicode($d);
+            eval { $addr = $addr =~ /\@/ ? email_to_unicode($addr)
+                                         : domain_to_unicode($addr);
+            };
+            $ret = $@;
         }
         else {
-            softdie ("Unknown encoding: ". $e, %options);
-            return;
+            die "Unknown encoding ‘".$e."’";
         }
     }
-    return ($l,$d);
+    softdie ($mesg, %options) // return if $ret;
+    return ('',$addr) unless $addr =~ /\@/;
+
+    $addr =~ /^(.*)\@([^\@]+)$/;
+    return ($1,$2);
 }
 
 sub ldap_error {
@@ -252,7 +265,7 @@ sub ldap_and_filter {
 }
 
 
-sub clean_ldap_entry {
+sub ldap_clean_entry {
     my $attrs = shift;
 
     foreach (keys %$attrs) {
@@ -270,6 +283,28 @@ sub clean_ldap_entry {
     }
 }
 
+sub ldap_assert_absent {
+    my $self = shift;
+    my $name = shift;
+    my $found = shift // "‘".$name."’ exists";
+    my %options = @_;
+
+    my $mesg = $self->ldap->search( base => $self->mail2dn( $name )
+                                  , scope => 'base'
+                                  , deref => 'never'
+                                  , filter => '(objectClass=*)'
+                                  , attrs => [ '1.1' ]
+                                  );
+    $options{'-die'} = { Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT => 0
+                       , Net::LDAP::Constant::LDAP_SUCCESS =>
+                             $options{'-append'} ? 0 : $found
+                       };
+    ldap_error($mesg, %options) // return;
+    return $mesg->code eq Net::LDAP::Constant::LDAP_SUCCESS ? 1 :
+           $mesg->code eq Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT ? 0 :
+           undef
+}
+
 =head1 AUTHOR
 
 Guilhem Moulin C<< <guilhem at fripost.org> >>