File Coverage

blib/lib/Set/NestedGroups.pm

Criterion	Covered	Total	%
statement	70	141	49.6
branch	6	34	17.6
condition	8	23	34.7
subroutine	14	21	66.6
pod	9	14	64.2
total	107	233	45.9

package Set::NestedGroups;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Set::NestedGroups::Member;
use Carp;

@ISA = qw();
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(

);
$VERSION = '0.01';

# Constructor
sub new {
    my $proto=shift;
    my $fh=shift;
    my $class=ref($proto) || $proto;
    my $self = {};
    bless($self,$class);

    if(defined $fh){
      if(ref($fh) eq "DBI::st"){
	  $fh->execute();
	  for(my $i=0;$i<$fh->rows();$i++){
	    my ($member,$group)=$fh->fetchrow();
	    $self->add($member,$group);
	  }
      }  else {
	no strict "refs"; # Can't use strict here,
			  # incase called with (DATA) instead
			  # of \*DATA
	$fh=to_filehandle($fh);
	while(<$fh>){
	  chomp;
	  last if(/^=$/);
	  my ($member,$group)=split(/=/,$_,2);
	  $self->add(unescape($member),unescape($group));
	}
      }
    }
    return $self;
}

# Add a member to a group
sub add {
    my $self=shift;
    my ($member,$group)=@_;
    my $was= $self->{'MEMBERS'}{$member}{$group};
    $self->{'MEMBERS'}{$member}{$group}=1;
    return $was;
}

# And remove a member from a group
sub remove {
    my $self=shift;
    my ($member,$group)=@_;
    my $was=$self->{'MEMBERS'}{$member}{$group};
    delete $self->{'MEMBERS'}{$member}{$group};
    $self->{'GROUPS'}{$group}--;
    if($self->{'GROUPS'}{$group} == 0){
	    delete $self->{'GROUPS'}{$group};
    }
    return $was;
}

# Create some sort of list object
sub list {
    my $self=shift;
    my %options=@_;
    my $member_list=new Set::NestedGroups::MemberList;
    my $nogroups = $options{'-nogroups'} || 0;

    foreach my $user (keys %{$self->{'MEMBERS'}}){
	next if($nogroups && $self->group($user));
	foreach my $group ($self->groups($user,%options)){
	    $member_list->add($user,$group);
	}
    }
    return $member_list;
}

sub to_filehandle {
    no strict "refs"; # Can't use strict here,
		      # incase called with (DATA) instead
		      # of \*DATA
    my $string = shift;
    if ($string && !ref($string)) {
	my($package) = caller(1);
	my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
	return $tmp if defined(fileno($tmp));
    }
    return $string;
}

# unescape URL-encoded data
sub unescape {
    my($todecode) = @_;
    $todecode =~ tr/+/ /;       # pluses become spaces
    $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
    return $todecode;
}

# URL-encode data
sub escape {
    my($toencode) = @_;
    $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
    return $toencode;
}

# Save the current object
sub save {
    my $self=shift;
    my $fh=shift;

    if(ref($fh) eq "DBI::st"){
      my $members=$self->list('-norecurse'=>1,-nomiddles=>0);
      for(my $i=0;$i<$members->rows();$i++){
	$fh->execute($members->next()) or return;
      }
      return 1;
    } else {
      no strict "refs"; # Can't use strict here,
			# incase called with (DATA) instead
			# of \*DATA
      $fh=to_filehandle($fh);

      my $members=$self->list('-norecurse'=>1,-nomiddles=>0);
      for(my $i=0;$i<$members->rows();$i++){
	  my ($member,$group)=$members->next();
	  print $fh escape($member),'=',escape($group),"\n" or return;
      }
      print $fh "=\n" or return;
  }
}

# Check a member
sub member {
    my $self=shift;
    my $member=shift;
    if(@_){
	my $want_group=shift;
	foreach my $got_group ($self->groups($member,-norecurse=>0,-nomiddles=>0)){
	    return 1 if($got_group eq $want_group);
	}
	return undef;
    }

    return (keys %{$self->{'MEMBERS'}{$member}})
}

# Check a group
sub group {
    my $self=shift;
    my $group=shift;

    return
	grep {$_ eq $group} $self->allgroups();
}

# Return all the members
sub allmembers {
    my $self=shift;
    return (keys %{$self->{'MEMBERS'}});
}

# Return all the groups
sub allgroups {
    my $self=shift;
    my $group=shift;
    my %seen;

    return
	grep  { !$seen{$_}++ }
	map { keys %{$self->{'MEMBERS'}{$_}} }
	$self->allmembers()
};


# Returns the groups a member belongs to
sub groups {
    my $self=shift;
    my $member=shift;
    my %options=@_;
    my $norecurse = $options{'-norecurse'} || 0;
    my $nomiddles= $options{'-nomiddles'} || 0;

    my %group=%{$self->{'MEMBERS'}{$member}};

    if(!$norecurse){
	my $again = 1;
	while($again){
	    $again=0;
	    foreach my $group (keys %group){
		foreach my $newgroup ( keys %{$self->{'MEMBERS'}{$group}}){
		    if(!$group{$newgroup}){
			$again=$group{$newgroup}=1;
		    }
		}
	    }
	}
    }
    return grep { !$nomiddles || !$self->member($_) }keys %group;
}

# Returns the members in a group
sub members {
    my $self=shift;
    my $group=shift;
    my %options=@_;
    my $nomiddles= $options{'-nomiddles'} || 0;
    my %members;

    foreach my $member ($self -> allmembers()){
	$members{$member}++ if(grep {$_ eq $group} $self->groups($member,%options));
    }

    return grep { !$nomiddles || !$self->group($_) }keys %members;
}

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__