File: NestedGroups.pm

package info (click to toggle)
libset-nestedgroups-perl 0.01-3
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 120 kB
  • sloc: perl: 204; makefile: 2
file content (391 lines) | stat: -rw-r--r-- 9,489 bytes parent folder | download
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
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__
# Below is the stub of documentation for your module. You better edit it!

=head1 NAME

Set::NestedGroups - grouped data eg ACL's, city/state/country etc

=head1 SYNOPSIS

  use Set::NestedGroups;
  $nested = new Set::NestedGroups;
  $nested->add('user','group');
  $nested->add('group','parentgroup');
  do_something() if($nested->member('user','parentgroup'));

=head1 DESCRIPTION

Set::NestedGroups gives an implementation of nested groups, 
access control lists (ACLs) would be one example of
nested groups.

For example, if Joe is a Manager, and Managers have access to payroll,
you can create an ACL which implements these rules, then ask the ACL
if Joe has access to payroll.

Another example, you may wish to track which city, state and country 
people are in, by adding people to cities, cities to states, and states
to countries.

=head1 CONSTRUTORS

=over 4

=item new()

creates a new Set::NestedGroups object.

=item new( fh )

creates a new Set::NestedGroups object, 
the object will be initialized using data read from this handle. For
details on the format, see the save() method

=item new( $sth )

creates a new Set::NestedGroups object, the object will be initialized
using data read using this this DBI statement handle.  For details on
the format, see the save() method

=head1 METHODS

=item add ( $member, $group) 

adds a member to a group. The group will be created if it doesn't
already exist.

=item remove ( $member, $group )

removes a member from a group. If this was the last member in this group,
then the group will be deleted. If the member was only in this group,
then the member will be deleted.

=item save(FILEHANDLE)

Outputs the object to the given filehandle, which must be already open
in write mode.

The format is compatible with the format used by CGI, and can be
used with new to initialize a new object;

Returns true if successfully wrote the data, or false if something
went wrong (usually that meant that the handle wasn't already open in
write mode).

=item save($sth)

Saves the object to a DBI database. This can be used with new to initialize
a new object. The $sth should be expecting 2 values, in this fashion:

  $sth = $dbh->prepare('insert into acl values (?,?)')
  $acl->save($dbh);
  $sth->finish();

  $sth = $dbh->prepare('select * from acl');
  $newacl=new ACL($sth);

Returns true if successfully wrote the data, or false if something
went wrong.

=item member ( $member, $group )

Returns true if $member is a member of $group.

=item member ( $member )

returns true if $member exists in any group.

=item group ( $group )

returns true if $group exists

=item groups ( $member, %options )

Returns the groups that $member belongs to. Options are explained below.

=item members ( $group , %options )

Returns the members of $group. Keep on reading for the options

=item list(%options)

Returns a Set::NestedGroups::Member object that will output an list
of the members & groups. This could be considered a calling of groups()
on each member, except this is more efficient.

The object can be used as follows.

  $list=$nested->list();
  for(my $i=0;$i<$list->rows();$i++){
    my ($member,$group)=$list->next();
    print "$member=$group\n";	
  }

=head2 options

By default, the above methods give every valid combination. However
you might not always want that. Therefore there are options which
can prevent return of certain values.

All of these examples presume that 'joe' is a member of 'managers',
and 'managers' is a member of payroll, and that you are using only
one of these options. You can use all 3, but that gets complicated
to explain.

-norecurse=>1

No Recursion is performed, method would ignore
payroll, and return only managers.

-nomiddles=>1

Doesn't returns groups 'in the middle', method would
ignore mangers, and return only payroll. 

-nogroups=>1

Doesn't return members that are groups. This only applies
to the list() method, in which case it acts like nomiddles, except on
the member instead of the group. list would ignore managers and
return joe => managers , joe => payroll.

=back 2

This sounds a lot more confusing than it actually is, once you try it
once or twice you'll get the idea.

=head1 AUTHOR

Alan R. Barclay, gorilla@elaine.drink.com

=head1 SEE ALSO

perl(1), CGI, DBI.

=cut