Permit user#zone syntax for users and groups. The zone given in using

this syntax will be honoured only with baton >= 0.16.3. With older
versions, the zone component will be ignored.

lib/WTSI/NPG/DriRODS.pm

@@ -58,7 +58,7 @@ stubs.
 
 =head1 DESCRIPTION
 
-This calss enables dry-run operations to be carried on iRODS out more
+This class enables dry-run operations to be carried on iRODS out more
 easily. Simply replace your iRODS handle with an instance of this
 class and all the method calls that would change data and/or metadata
 will be logged at INFO level, along with their arguments.

lib/WTSI/NPG/iRODS.pm

@@ -29,7 +29,7 @@ with 'WTSI::DNAP::Utilities::Loggable', 'WTSI::NPG::iRODS::Utilities';
 
 our $VERSION = '';
 
-our $MAX_BATON_VERSION = '0.16.2';
+our $MAX_BATON_VERSION = '0.16.3';
 our $MIN_BATON_VERSION = '0.16.0';
 
 our $IADMIN      = 'iadmin';
@@ -310,11 +310,7 @@ has '_permissions_cache' =>
 sub BUILD {
   my ($self) = @_;
 
-  my ($installed_baton_version) = WTSI::DNAP::Utilities::Runnable->new
-    (executable  => 'baton-list',
-     arguments   => ['--version'],
-     environment => $self->environment,
-     logger      => $self->logger)->run->split_stdout;
+  my $installed_baton_version = $self->installed_baton_version;
 
   if (not $self->match_baton_version($installed_baton_version)) {
     my $required_range = join q{ - }, $MIN_BATON_VERSION, $MAX_BATON_VERSION;
@@ -333,6 +329,18 @@ sub BUILD {
   return $self;
 }
 
+sub installed_baton_version {
+  my ($self) = @_;
+
+  my ($version) = WTSI::DNAP::Utilities::Runnable->new
+    (executable  => 'baton-list',
+     arguments   => ['--version'],
+     environment => $self->environment,
+     logger      => $self->logger)->run->split_stdout;
+
+  return $version;
+}
+
 sub match_baton_version {
   my ($self, $version) = @_;
 
@@ -630,7 +638,8 @@ sub remove_group {
                $WTSI::NPG::iRODS::WRITE_PERMISSION,
                $WTSI::NPG::iRODS::OWN_PERMISSION or
                $WTSI::NPG::iRODS::NULL_PERMISSION.
-  Arg [2]    : An iRODS group name.
+  Arg [2]    : An iRODS group name.  This may be of the form <group> or
+               <group>#<zone>
   Arg [3]    : One or more data objects or collections.
 
   Example    : $irods->set_group_access($WTSI::NPG::iRODS::READ_PERMISSION,
@@ -928,6 +937,22 @@ sub get_collection_permissions {
   return $self->sort_acl($self->acl_lister->get_collection_acl($collection));
 }
 
+=head2 set_collection_permissions
+
+  Arg [1]    : Permission, Str. One of $WTSI::NPG::iRODS::READ_PERMISSION,
+               $WTSI::NPG::iRODS::WRITE_PERMISSION,
+               $WTSI::NPG::iRODS::OWN_PERMISSION or
+               $WTSI::NPG::iRODS::NULL_PERMISSION.
+  Arg [2]    : Owner (user or group). This may be of the form <user> or
+               <user>#<zone>.
+
+  Example    : $irods->set_collection_permissions('read', 'user1', $path)
+  Description: Set access permissions on the collection. Return the collection
+               path.
+  Returntype : Str
+
+=cut
+
 sub set_collection_permissions {
   my ($self, $level, $owner, $collection) = @_;
 
@@ -953,10 +978,14 @@ sub set_collection_permissions {
 
   my @acl = $self->get_collection_permissions($collection);
 
-  if (any { $_->{owner} eq $owner and
+  my ($owner_name, $zone) = split /\#/msx, $owner;
+  $zone ||= $self->find_zone_name($collection);
+
+  if (any { $_->{owner} eq $owner_name and
+            $_->{zone}  eq $zone       and
             $_->{level} eq $perm_str } @acl) {
     $self->debug("'$collection' already has permission ",
-                 "'$perm_str' for '$owner'");
+                 "'$perm_str' for '$owner_name#$zone'");
   }
   else {
     $self->acl_modifier->chmod_collection($perm_str, $owner, $collection);
@@ -1501,7 +1530,7 @@ sub move_object {
   $source = $self->_ensure_object_path($source);
   $target = $self->_ensure_absolute_path($target);
   $self->debug("Moving object from '$source' to '$target'");
-  $self->_path_cache->remove($source);
+  $self->_clear_caches($source);
 
   WTSI::DNAP::Utilities::Runnable->new(executable  => $IMV,
                                        arguments   => [$source, $target],
@@ -1567,7 +1596,7 @@ sub remove_object {
 
   $object = $self->_ensure_object_path($object);
   $self->debug("Removing object '$object'");
-  $self->_path_cache->remove($object);
+  $self->_clear_caches($object);
 
   WTSI::DNAP::Utilities::Runnable->new(executable  => $IRM,
                                        arguments   => [$object],
@@ -1635,6 +1664,23 @@ sub get_object_permissions {
   return @{$cached};
 }
 
+=head2 set_object_permissions
+
+  Arg [1]    : Permission, Str. One of $WTSI::NPG::iRODS::READ_PERMISSION,
+               $WTSI::NPG::iRODS::WRITE_PERMISSION,
+               $WTSI::NPG::iRODS::OWN_PERMISSION or
+               $WTSI::NPG::iRODS::NULL_PERMISSION.
+  Arg [2]    : Owner (user or group). This may be of the form <user> or
+               <user>#<zone>.
+  Arg [3]    : Path, Str.
+
+  Example    : $irods->set_object_permissions('read', 'user1', $path)
+  Description: Set access permissions on the data objecrt. Return the object
+               path.
+  Returntype : Str
+
+=cut
+
 sub set_object_permissions {
   my ($self, $level, $owner, $object) = @_;
 
@@ -1658,23 +1704,27 @@ sub set_object_permissions {
   $self->debug("Setting permissions on '$object' to '$perm_str' for '$owner'");
   my @acl = $self->get_object_permissions($object);
 
-  if (any { $_->{owner} eq $owner and
+  my ($owner_name, $zone) = split /\#/msx, $owner;
+  $zone ||= $self->find_zone_name($object);
+
+  if (any { $_->{owner} eq $owner_name and
+            $_->{zone}  eq $zone       and
             $_->{level} eq $perm_str } @acl) {
-    $self->debug("'$object' already has permission '$perm_str' for '$owner'");
+    $self->debug("'$object' already has permission ",
+                 "'$perm_str' for '$owner_name#$zone'");
   }
   else {
     $self->acl_modifier->chmod_object($perm_str, $owner, $object);
 
     # Having 'null' permission means having no permission, so these
     # must be removed from the cached ACL.
-    my @remain =
-      grep { $_->{owner} ne $owner and
-             $_->{level} ne $WTSI::NPG::iRODS::NULL_PERMISSION } @acl;
-    my $zone = $self->find_zone_name($object);
+    my @remain = grep { not ($_->{owner} eq $owner_name and
+                             $_->{zone}  eq $zone) } @acl;
+
     my $cached = $self->_cache_permissions($object,
-                                           [@remain, {owner => $owner,
-                                                      level => $perm_str,
-                                                      zone  => $zone}]);
+                                           [@remain, {owner => $owner_name,
+                                                      zone  => $zone,
+                                                      level => $perm_str}]);
   }
 
   return $object;
@@ -2268,13 +2318,29 @@ sub _cache_metadata {
 sub _cache_permissions {
   my ($self, $path, $acl) = @_;
 
-  my $sorted = [$self->sort_acl(@{$acl})];
+  # Having 'null' permission means having no permission, so these
+  # must not be cached.
+  my @to_cache =
+    grep { $_->{level} ne $WTSI::NPG::iRODS::NULL_PERMISSION } @{$acl};
+
+  my $sorted = [$self->sort_acl(@to_cache)];
   $self->_permissions_cache->set($path, $sorted);
   $self->debug("Updated ACL cache for '$path': ", pp($sorted));
 
   return $sorted;
 }
 
+sub _clear_caches {
+  my ($self, $path) = @_;
+
+  $self->debug("Clearing cached path, AVUs abd ACL for '$path'");
+  $self->_path_cache->remove($path);
+  $self->_permissions_cache->remove($path);
+  $self->_metadata_cache->remove($path);
+
+  return;
+}
+
 sub DEMOLISH {
   my ($self, $in_global_destruction) = @_;
 
@@ -2329,6 +2395,7 @@ no Moose;
 
 __END__
 
+
 =head1 NAME
 
 WTSI::NPG::iRODS

lib/WTSI/NPG/iRODS/ACLModifier.pm

@@ -38,11 +38,19 @@ sub chmod_object {
   my ($volume, $collection, $data_name) = File::Spec->splitpath($object);
   $collection = File::Spec->canonpath($collection);
 
+  my ($name, $zone) = split /\#/msx, $owner;
+  $self->debug("Parsed owner name '$name' from '$owner' for '$object'");
+
+  my $perm = {owner => $name,
+              level => $permission};
+  if ($zone) {
+    $self->debug("Parsed owner zone '$zone' from '$owner' for '$object'");
+    $perm->{zone} = $zone;
+  }
+
   my $spec = {collection  => $collection,
               data_object => $data_name,
-              access      => [{owner => $owner,
-                               level => $permission}]};
-
+              access      => [$perm]};
   my $response = $self->communicate($spec);
   $self->validate_response($response);
   $self->report_error($response);
@@ -51,10 +59,10 @@ sub chmod_object {
 }
 
 sub chmod_collection {
-  my ($self, $level, $owner, $collection) = @_;
+  my ($self, $permission, $owner, $collection) = @_;
 
-  defined $level or
-    $self->logconfess('A defined level argument is required');
+  defined $permission or
+    $self->logconfess('A defined permission argument is required');
   defined $owner or
     $self->logconfess('A defined owner argument is required');
   defined $collection or
@@ -66,10 +74,18 @@ sub chmod_collection {
 
   $collection = File::Spec->canonpath($collection);
 
-  my $spec = {collection  => $collection,
-              access      => [{owner => $owner,
-                               level => $level}]};
+  my ($name, $zone) = split /\#/msx, $owner;
+  $self->debug("Parsed owner name '$name' from '$owner' for '$collection'");
+
+  my $perm = {owner => $name,
+              level => $permission};
+  if ($zone) {
+    $self->debug("Parsed owner zone '$zone' from '$owner' for '$collection'");
+    $perm->{zone} = $zone;
+  }
 
+  my $spec = {collection => $collection,
+              access     => [$perm]};
   my $response = $self->communicate($spec);
   $self->validate_response($response);
   $self->report_error($response);
@@ -99,7 +115,7 @@ Keith James <[email protected]>
 
 =head1 COPYRIGHT AND DISCLAIMER
 
-Copyright (C) 2014 Genome Research Limited. All Rights Reserved.
+Copyright (C) 2014, 2016 Genome Research Limited. All Rights Reserved.
 
 This program is free software: you can redistribute it and/or modify
 it under the terms of the Perl Artistic License or the GNU General

lib/WTSI/NPG/iRODS/Collection.pm

@@ -232,7 +232,8 @@ sub get_permissions {
                $WTSI::NPG::iRODS::WRITE_PERMISSION,
                $WTSI::NPG::iRODS::OWN_PERMISSION or
                $WTSI::NPG::iRODS::NULL_PERMISSION.
-  Arg [2]    : Array of owners (users and /or groups).
+  Arg [2]    : Array of owners (users and/or groups). These may be of the
+               form <user> or <user>#<zone>.
 
   Example    : $coll->set_permissions('read', 'user1', 'group1')
   Description: Set access permissions on the collection. Return self.

lib/WTSI/NPG/iRODS/DataObject.pm

@@ -272,7 +272,8 @@ sub get_permissions {
                $WTSI::NPG::iRODS::WRITE_PERMISSION,
                $WTSI::NPG::iRODS::OWN_PERMISSION or
                $WTSI::NPG::iRODS::NULL_PERMISSION.
-  Arg [2]    : Array of owners (users and /or groups).
+  Arg [2]    : Array of owners (users and /or groups). These may be of the
+               form <user> or <user>#<zone>.
 
   Example    : $obj->set_permissions($WTSI::NPG::iRODS::READ_PERMISSION,
                                      'user1', 'group1')

t/lib/WTSI/NPG/iRODS/CollectionTest.pm

@@ -305,7 +305,7 @@ sub get_permissions : Test(1) {
   ok($perms, 'Permissions obtained');
 }
 
-sub set_permissions : Test(7) {
+sub set_permissions : Test(9) {
   my $irods = WTSI::NPG::iRODS->new(environment          => \%ENV,
                                     strict_baton_version => 0);
   my $coll_path = "$irods_tmp_coll/irods_path_test/test_dir";
@@ -316,7 +316,8 @@ sub set_permissions : Test(7) {
     $coll->get_permissions;
   ok($r0, 'No public read access');
 
-  ok($coll->set_permissions('read', 'public'));
+  ok($coll->set_permissions('read', 'public'),
+     'Set permission using an implicit zone');
 
   my $r1 = any { exists $_->{owner} && $_->{owner} eq 'public' &&
                  exists $_->{level} && $_->{level} eq 'read' }
@@ -330,11 +331,26 @@ sub set_permissions : Test(7) {
     $coll->get_permissions;
   ok($r2, 'Removed public read access');
 
+  my $zone = $irods->find_zone_name($irods_tmp_coll);
+  ok($coll->set_permissions('read', "public#$zone"),
+     'Set permission using an explicit zone');
+
   dies_ok { $coll->set_permissions('bogus_permission', 'public') }
     'Fails to set bogus permission';
 
   dies_ok { $coll->set_permissions('read', 'bogus_group') }
     'Fails to set permission for bogus group';
+
+ SKIP: {
+    my $version = $irods->installed_baton_version;
+    my ($dotted_version, $commits) = $version =~ m{^(\d+[.]\d+[.]\d+)(\S*)$}msx;
+
+    skip "baton $version is < 0.16.3", 1 unless
+      version->parse($dotted_version) > version->parse('0.16.2');
+
+    dies_ok { $coll->set_permissions('read', 'public#no_such_zone') }
+      'Fails to set permission using a non-existent zone';
+  }
 }
 
 sub get_groups : Test(7) {

t/lib/WTSI/NPG/iRODS/DataObjectTest.pm

@@ -498,7 +498,7 @@ sub get_permissions : Test(1) {
   ok($perms, 'Permissions obtained');
 }
 
-sub set_permissions : Test(7) {
+sub set_permissions : Test(9) {
   my $irods = WTSI::NPG::iRODS->new(environment          => \%ENV,
                                     strict_baton_version => 0);
   my $obj_path = "$irods_tmp_coll/irods_path_test/test_dir/test_file.txt";
@@ -511,7 +511,8 @@ sub set_permissions : Test(7) {
   ok($r0, 'No public read access');
 
   # Set public read
-  ok($obj->set_permissions('read', 'public'));
+  ok($obj->set_permissions('read', 'public'),
+     'Set permission using an implicit zone');
 
   my $r1 = any { exists $_->{owner} && $_->{owner} eq 'public' &&
                  exists $_->{level} && $_->{level} eq 'read' }
@@ -526,11 +527,26 @@ sub set_permissions : Test(7) {
     $obj->get_permissions;
   ok($r2, 'Removed public read access');
 
+  my $zone = $irods->find_zone_name($irods_tmp_coll);
+  ok($obj->set_permissions('read', "public#$zone"),
+     'Set permission using an explicit zone');
+
   dies_ok { $obj->set_permissions('bogus_permission', 'public') }
     'Fails to set bogus permission';
 
   dies_ok { $obj->set_permissions('read', 'bogus_group') }
     'Fails to set permission for bogus group';
+
+ SKIP: {
+    my $version = $irods->installed_baton_version;
+    my ($dotted_version, $commits) = $version =~ m{^(\d+[.]\d+[.]\d+)(\S*)$}msx;
+
+    skip "baton $version is < 0.16.3", 1 unless
+      version->parse($dotted_version) > version->parse('0.16.2');
+
+    dies_ok { $obj->set_permissions('read', 'public#no_such_zone') }
+      'Fails to set permission using a non-existent zone';
+  }
 }
 
 sub get_groups : Test(7) {