From 1f35ed5ce38525af78508b46eea67a4f41c74a4a Mon Sep 17 00:00:00 2001
From: Guilhem Moulin <guilhem.moulin@fripost.org>
Date: Fri, 18 Jan 2013 21:44:37 +0100
Subject: =?UTF-8?q?Fripost::Schema::Misc=20=E2=86=92=20Fripost::Schema::Ut?=
 =?UTF-8?q?il?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 lib/Fripost/Schema/Util.pm | 173 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 173 insertions(+)
 create mode 100644 lib/Fripost/Schema/Util.pm

(limited to 'lib/Fripost/Schema/Util.pm')

diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm
new file mode 100644
index 0000000..8d75a3a
--- /dev/null
+++ b/lib/Fripost/Schema/Util.pm
@@ -0,0 +1,173 @@
+package Fripost::Schema::Util;
+
+=head1 NAME
+
+Util.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
+                     canonical_dn ldap_explode_dn
+                     split_addr/;
+use Email::Valid;
+use Net::IDN::Encode;
+use Net::LDAP::Util;
+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 @dn = @{ldap_explode_dn ($dn)};
+    shift @dn;
+    my $dn2 = canonical_dn (@dn);
+    my $perms = '';
+
+    $perms .= 'a'
+        if grep { $dn eq $_  or  $dn2 eq $_ }
+                $entry->get_value ('fripostCanCreateAlias');
+
+    $perms .= 'l'
+        if grep { $dn eq $_  or  $dn2 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 <email>" 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;
+}
+
+sub canonical_dn {
+    Net::LDAP::Util::canonical_dn(\@_, casefold => 'lower'
+                                     , mbcescape => 1
+                                     , reverse => 0
+                                     , separator => ',');
+};
+
+sub ldap_explode_dn {
+    Net::LDAP::Util::ldap_explode_dn( join (',', @_), casefold => 'lower' )
+}
+
+sub split_addr {
+    my $addr = shift;
+    my %options = @_;
+
+    if (defined $options{'-encode'}) {
+        my $e = $options{'-encode'};
+        if ($e eq 'ascii') {
+            $addr = Net::IDN::Encode::email_to_ascii($addr);
+        }
+        elsif ($e eq 'unicode') {
+            $addr = Net::IDN::Encode::email_to_unicode($addr);
+        }
+        else {
+            die "Unknown encoding: ". $e;
+        }
+    }
+
+    split /\@/, $addr, 2;
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012,2013 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__
-- 
cgit v1.2.3