/usr/share/perl5/User/Identity/Collection.pm is in libuser-identity-perl 0.96-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | # Copyrights 2003-2016 by [Mark Overmeer <perl@overmeer.net>].
# For other contributors see Changes.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
package User::Identity::Collection;
use vars '$VERSION';
$VERSION = '0.96';
use base 'User::Identity::Item';
use strict;
use warnings;
use User::Identity;
use Carp;
use List::Util qw/first/;
use overload '""' => sub {
my $self = shift;
$self->name . ": " . join(", ", sort map {$_->name} $self->roles);
};
use overload '@{}' => sub { [ shift->roles ] };
#-----------------------------------------
sub type { "people" }
sub init($)
{ my ($self, $args) = @_;
defined($self->SUPER::init($args)) or return;
$self->{UIC_itype} = delete $args->{item_type} or die;
$self->{UIC_roles} = { };
my $roles = $args->{roles};
my @roles
= ! defined $roles ? ()
: ref $roles eq 'ARRAY' ? @$roles
: $roles;
$self->addRole($_) foreach @roles;
$self;
}
#-----------------------------------------
sub roles() { values %{shift->{UIC_roles}} }
sub itemType { shift->{UIC_itype} }
#-----------------------------------------
sub addRole(@)
{ my $self = shift;
my $maintains = $self->itemType;
my $role;
if(ref $_[0] && ref $_[0] ne 'ARRAY')
{ $role = shift;
croak "ERROR: Wrong type of role for ".ref($self)
. ": requires a $maintains but got a ". ref($role)
unless $role->isa($maintains);
}
else
{ $role = $maintains->new(ref $_[0] ? @{$_[0]} : @_);
croak "ERROR: Cannot create a $maintains to add this to my collection."
unless defined $role;
}
$role->parent($self);
$self->{UIC_roles}{$role->name} = $role;
$role;
}
sub removeRole($)
{ my ($self, $which) = @_;
my $name = ref $which ? $which->name : $which;
my $role = delete $self->{UIC_roles}{$name} or return ();
$role->parent(undef);
$role;
}
sub renameRole($$$)
{ my ($self, $which, $newname) = @_;
my $name = ref $which ? $which->name : $which;
if(exists $self->{UIC_roles}{$newname})
{ $self->log(ERROR=>"Cannot rename $name into $newname: already exists");
return ();
}
my $role = delete $self->{UIC_roles}{$name};
unless(defined $role)
{ $self->log(ERROR => "Cannot rename $name into $newname: doesn't exist");
return ();
}
$role->name($newname); # may imply change other attributes.
$self->{UIC_roles}{$newname} = $role;
}
sub sorted() { sort {$a->name cmp $b->name} shift->roles}
#-----------------------------------------
sub find($)
{ my ($self, $select) = @_;
!defined $select ? ($self->roles)[0]
: !ref $select ? $self->{UIC_roles}{$select}
: wantarray ? grep ({ $select->($_, $self) } $self->roles)
: first { $select->($_, $self) } $self->roles;
}
1;
|