more progress but stalled at regexp acl handling

lib/App/Netdisco/Util/Permission.pm

@@ -10,7 +10,12 @@ use App::Netdisco::Util::DNS 'hostname_from_ip';
 
 use base 'Exporter';
 our @EXPORT = ();
-our @EXPORT_OK = qw/check_acl check_acl_no check_acl_only/;
+our @EXPORT_OK = qw/
+  check_acl
+  check_acl_no 
+  check_acl_only
+  acl_to_where_clause
+/;
 our %EXPORT_TAGS = (all => \@EXPORT_OK);
 
 =head1 NAME
@@ -217,4 +222,135 @@ sub check_acl {
   return ($all ? 1 : 0);
 }
 
-1;
+=head2 acl_to_where_clause( $setting_name | $acl_entry | \@acl )
+
+Returns an L<SQL::Abstract> where clause which when applied to the devices
+table should return the matching records only.
+
+If C<$setting_name> is a valid setting, then it will be resolved to the access
+control list, else we assume you passed an ACL entry or ACL.
+
+A missing parameter will return the C<sqltrue> value (usually C<1=1>).
+
+See L<the Netdisco wiki|https://github.com/netdisco/netdisco/wiki/Configuration#access-control-lists>
+for details of what C<$acl> may contain.
+
+=cut
+
+sub check_acl_only {
+  my ($setting_name) = @_;
+  return (1 => 1) unless $setting_name;
+  my $config = (exists config->{"$setting_name"} ? setting($setting_name)
+                                                 : $setting_name);
+  
+  $config  = [$config] if ref [] ne ref $config;
+  my $all  = (scalar grep {$_ eq 'op:and'} @$config);
+  
+  my $ropt = { retry => 1, retrans => 1, udp_timeout => 1, tcp_timeout => 2 };
+  my $qref = ref qr//;
+  my %where = ();
+  
+  INLIST: foreach (@$config) {
+      my $item = $_; # must copy so that we can modify safely
+      next INLIST if !defined $item or $item eq 'op:and';
+
+      if ($qref eq ref $item) {
+          push @{ $where{dns}{
+          $name = ($name || hostname_from_ip($addr->addr, $ropt) || '!!none!!');
+          if ($name =~ $item) {
+            return 1 if not $all;
+          }
+          else {
+            return 0 if $all;
+          }
+          next INLIST;
+      }
+
+      my $neg = ($item =~ s/^!//);
+
+      if ($item =~ m/^group:(.+)$/) {
+          my $group = $1;
+          setting('host_groups')->{$group} ||= [];
+
+          if ($neg xor check_acl($thing, setting('host_groups')->{$group})) {
+            return 1 if not $all;
+          }
+          else {
+            return 0 if $all;
+          }
+          next INLIST;
+      }
+
+      if ($item =~ m/^([^:]+):([^:]+)$/) {
+          my $prop  = $1;
+          my $match = $2;
+
+          # if not an object, we can't do much with properties
+          next INLIST unless blessed $thing;
+
+          # lazy version of vendor: and model:
+          if ($neg xor ($thing->can($prop) and defined eval { $thing->$prop }
+              and $thing->$prop =~ m/^$match$/)) {
+            return 1 if not $all;
+          }
+          else {
+            return 0 if $all;
+          }
+          next INLIST;
+      }
+
+      if ($item =~ m/[:.]([a-f0-9]+)-([a-f0-9]+)$/i) {
+          my $first = $1;
+          my $last  = $2;
+
+          if ($item =~ m/:/) {
+              next INLIST if $addr->bits != 128 and not $all;
+
+              $first = hex $first;
+              $last  = hex $last;
+
+              (my $header = $item) =~ s/:[^:]+$/:/;
+              foreach my $part ($first .. $last) {
+                  my $ip = NetAddr::IP::Lite->new($header . sprintf('%x',$part) . '/128')
+                    or next;
+                  if ($neg xor ($ip == $addr)) {
+                    return 1 if not $all;
+                    next INLIST;
+                  }
+              }
+              return 0 if (not $neg and $all);
+              return 1 if ($neg and not $all);
+          }
+          else {
+              next INLIST if $addr->bits != 32 and not $all;
+
+              (my $header = $item) =~ s/\.[^.]+$/./;
+              foreach my $part ($first .. $last) {
+                  my $ip = NetAddr::IP::Lite->new($header . $part . '/32')
+                    or next;
+                  if ($neg xor ($ip == $addr)) {
+                    return 1 if not $all;
+                    next INLIST;
+                  }
+              }
+              return 0 if (not $neg and $all);
+              return 1 if ($neg and not $all);
+          }
+          next INLIST;
+      }
+
+      my $ip = NetAddr::IP::Lite->new($item)
+        or next INLIST;
+      next INLIST if $ip->bits != $addr->bits and not $all;
+
+      if ($neg xor ($ip->contains($addr))) {
+        return 1 if not $all;
+      }
+      else {
+        return 0 if $all;
+      }
+      next INLIST;
+  }
+}
+
+true;