Return to longroup.pm CVS log

Up to [LON-CAPA] / loncom / interface

Apparently longroup.pm was omitted from prior commit.   &coursegroups() and &get_group_settings() moved to longroup.pm, which contains general utility functions for asking about groups.  Also contains &group_changes() which is used to add/drop group memberships as a result of role changes, as determined by group settings for auto-add and auto-drop.

    1: # The LearningOnline Network with CAPA
    2: # accessor routines used to provide information about course groups 
    3: #
    4: # Copyright Michigan State University Board of Trustees
    5: #
    6: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    7: #
    8: # LON-CAPA is free software; you can redistribute it and/or modify
    9: # it under the terms of the GNU General Public License as published by
   10: # the Free Software Foundation; either version 2 of the License, or
   11: # (at your option) any later version.
   12: #
   13: # LON-CAPA is distributed in the hope that it will be useful,
   14: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   15: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16: # GNU General Public License for more details.
   17: #
   18: # You should have received a copy of the GNU General Public License
   19: # along with LON-CAPA; if not, write to the Free Software
   20: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   21: #
   22: # /home/httpd/html/adm/gpl.txt
   23: #
   24: # http://www.lon-capa.org/
   25: #
   26:                                                                                 
   27: package Apache::longroup;
   28:                                                                                 
   29: use strict;
   30: use Apache::lonnet;
   31: 
   32: ###############################################
   33: =pod
   34: 
   35: =item coursegroups
   36: 
   37: Retrieve information about groups in a course,
   38: 
   39: Input:
   40: 1. Optional course domain
   41: 2. Optional course number
   42: 3. Optional group name
   43: 
   44: Course domain and number will be taken from user's
   45: environment if not supplied. Optional group name will 
   46: be passed to lonnet::get_coursegroups() as a regexp to
   47: use in the call to the dump function.
   48:                                                                                 
   49: Output
   50: Returns hash of groups in the course (subject to the
   51: optional group name filter). In the hash, the keys are
   52: group names, and their corresponding values
   53: are scalars containing group information in XML. This
   54: can be sent to &get_group_settings() to be parsed.
   55: 
   56: Side effects:
   57: None.
   58: =cut
   59: 
   60: ###############################################
   61: 
   62: sub coursegroups {
   63:     my ($cdom,$cnum,$group) = @_;
   64:     if (!defined($cdom) || !defined($cnum)) {
   65:         my $cid =  $env{'request.course.id'};
   66: 
   67:         return if (!defined($cid));
   68: 
   69:         $cdom = $env{'course.'.$cid.'.domain'};
   70:         $cnum = $env{'course.'.$cid.'.num'};
   71:     }
   72:     my %curr_groups = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group);
   73:     my ($tmp) = keys(%curr_groups);
   74:     if ($tmp=~/^(con_lost|no_such_host|error: [^2] )/) {
   75:         undef(%curr_groups);
   76:         &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.$cdom);
   77:     } elsif ($tmp=~/^error: 2 /) {
   78:         undef(%curr_groups);
   79:     }
   80:     return %curr_groups;
   81: }
   82: 
   83: ###############################################
   84: 
   85: =item get_group_settings
   86:                                                                                 
   87: Uses TokeParser to extract group information from the
   88: XML used to describe course groups.
   89:                                                                                 
   90: Input:
   91: Scalar containing XML  - as retrieved from &coursegroups().
   92:                                                                                 
   93: Output:
   94: Hash containing group information as key=values for (a), and
   95: hash of hashes for (b)
   96:                                                                                 
   97: Keys (in two categories):
   98: (a) groupname, creator, creation, modified, startdate,enddate.
   99: Corresponding values are name of the group, creator of the group
  100: (username:domain), UNIX time for date group was created, and
  101: settings were last modified, and default start and end access
  102: times for group members.
  103:                                                                                 
  104: (b) functions returned in hash of hashes.
  105: Outer hash key is functions.
  106: Inner hash keys are chat,discussion,email,files,homepage,roster.
  107: Corresponding values are either on or off, depending on
  108: whether this type of functionality is available for the group.
  109:                                                                                 
  110: =cut
  111: 
  112: ###############################################
  113: 
  114: sub get_group_settings {
  115:     my ($groupinfo)=@_;
  116:     my $parser=HTML::TokeParser->new(\$groupinfo);
  117:     my $token;
  118:     my $tool = '';
  119:     my $role = '';
  120:     my %content=();
  121:     while ($token=$parser->get_token) {
  122:         if ($token->[0] eq 'S')  {
  123:             my $entry=$token->[1];
  124:             if ($entry eq 'functions' || $entry eq 'autosec') {
  125:                 %{$content{$entry}} = ();
  126:                 $tool = $entry;
  127:             } elsif ($entry eq 'role') {
  128:                 if ($tool eq 'autosec') {
  129:                     $role = $token->[2]{id};
  130:                     @{$content{$tool}{$role}} = ();
  131:                 }
  132:             } else {
  133:                 my $value=$parser->get_text('/'.$entry);
  134:                 if ($entry eq 'name') {
  135:                     if ($tool eq 'functions') {
  136:                         my $function = $token->[2]{id};
  137:                         $content{$tool}{$function} = $value;
  138:                     }
  139:                 } elsif ($entry eq 'groupname') {
  140:                     $content{$entry}=&unescape($value);
  141:                 } elsif (($entry eq 'roles') || ($entry eq 'types') ||
  142:                          ($entry eq 'sectionpick') || ($entry eq 'defpriv')) {
  143:                     push(@{$content{$entry}},$value);
  144:                 } elsif ($entry eq 'section') {
  145:                     if ($tool eq 'autosec'  && $role ne '') {
  146:                         push(@{$content{$tool}{$role}},$value);
  147:                     }
  148:                 } else {
  149:                     $content{$entry}=$value;
  150:                 }
  151:             }
  152:         } elsif ($token->[0] eq 'E') {
  153:             if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') {
  154:                 $tool = '';
  155:             } elsif ($token->[1] eq 'role') {
  156:                 $role = '';
  157:             }
  158:                                                                                 
  159:         }
  160:     }
  161:     return %content;
  162: }
  163: 
  164: ###############################################
  165: 
  166: sub check_group_access {
  167:     my ($group) = @_;
  168:     my $access = 1;
  169:     my $now = time;
  170:     my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group});
  171:     if (($end!=0) && ($end<$now)) { $access = 0; }
  172:     if (($start!=0) && ($start>$now)) { $access=0; }
  173:     return $access;
  174: }
  175: 
  176: ###############################################
  177: 
  178: =pod
  179:                                                                                 
  180: =item group_changes
  181: 
  182: Add or drop group memberships in a course as a result of
  183: changes in a user's roles/sections. Called by
  184: &Apache::lonnet:assignrole()     
  185:                                                                                 
  186: Input:
  187: 1. User's domain
  188: 2. User's username
  189: 3. Url of role
  190: 4. Role
  191: 5. End date of role
  192: 6. Start date of role
  193: 
  194: Checks to see if role for which assignment is being made is in a course.
  195: If so, gathers information about auto-group population settings for
  196: groups in the course.
  197: 
  198: If role is being expired, will also expire any group memberships that
  199: are specified for auto-group population for the specific role and
  200: section (including section 'none' and 'all' sections), unless a
  201: different role/section also included in auto-group population
  202: for the course is included amongst the user's unexpired roles
  203: and would trigger membership in teh same group(s) 
  204: 
  205: If role is being added, will add any group memberships specified
  206: for auto-group population, unless use is already a group member.
  207: Uses default group privileges and default start and end group access
  208: times. 
  209: 
  210: Output
  211: None
  212: 
  213: Side effects:
  214: May result in calls to Apache::lonnet::modify_group_roles()
  215: and Apache::lonnet::modify_coursegroup_membership() to add
  216: or expire group membership(s) for a user. 
  217: 
  218: =cut
  219: 
  220: sub group_changes {
  221:     my ($udom,$uname,$url,$role,$origend,$origstart) = @_;
  222:     my $now = time;
  223:     my $chgtype;
  224:     if ($origend > 0 && $origend <= $now) {
  225:         $chgtype = 'drop';
  226:     } else {
  227:         $chgtype = 'add';
  228:     }
  229:     my ($cid,$cdom,$cnum,$sec);
  230:     if ($url =~ m-^(/[^/]+/[^/]+)/([^/]+)$-) {
  231:         $cid = $1;
  232:         $sec = $2;
  233:     } else {
  234:         $cid = $url;
  235:     }
  236:     my $courseid = $cid;
  237:     $courseid =~ s|^/||;
  238:     $courseid =~ s|/|_|;
  239:     my %crshash=&Apache::lonnet::coursedescription($cid);
  240:     $cdom = $crshash{'domain'};
  241:     $cnum = $crshash{'num'};
  242:     if (defined($cdom) && defined($cnum)) {
  243:         my %settings;
  244:         my @changegroups = ();
  245:         my %dropgroup = ();
  246:         my %dropstart = ();
  247:         my %addgroup = ();
  248:         my %curr_groups = &coursegroups($cdom,$cnum);
  249:         if (%curr_groups) {
  250:             foreach my $group (keys(%curr_groups)) {
  251:                 %{$settings{$group}}=&get_group_settings($curr_groups{$group});
  252:                 if ($chgtype eq 'add') {
  253:                     if (!($settings{$group}{autoadd} eq 'on')) {
  254:                         next;
  255:                     }
  256:                 } else {
  257:                     if (!($settings{$group}{autodrop} eq 'on')) {
  258:                         next;
  259:                     }
  260:                 }
  261:                 my @autosec = ();
  262:                 if (ref($settings{$group}{'autosec'}{$role}) eq 'ARRAY') {
  263:                     @autosec = @{$settings{$group}{'autosec'}{$role}};
  264:                 }
  265:                 if ($sec eq '') {
  266:                     $sec = 'none';
  267:                 }
  268:                 if ((grep(/^$sec$/,@autosec)) || (grep(/^all$/,@autosec))) {
  269:                     push(@changegroups,$group);
  270:                 }
  271:             }
  272:         }
  273:        if (@changegroups > 0) {
  274:             my %currpriv;
  275:             my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname,$cid);
  276:             my ($tmp) = keys(%roleshash);
  277:             if ($tmp=~/^error:/) {
  278:                 &Apache::lonnet::logthis('Error retrieving roles: '.$tmp.
  279:                                          ' for '.$uname.':'.$udom);
  280:             } else {
  281:                 my $group_privs = '';
  282:                 foreach my $group (@changegroups) {
  283:                     if ($chgtype eq 'add') {
  284:                         if (ref($settings{$group}{'defpriv'}) eq 'ARRAY') {
  285:                             $group_privs =
  286:                                   join(':',@{$settings{$group}{'defpriv'}});
  287:                         }
  288:                     }
  289:                     my $key = $cid.'/'.$group.'_gr';
  290:                     if (defined($roleshash{$key})) {
  291:                         if ($roleshash{$key}=~ /^gr\/([^_]*)_(\d+)_([\-\d]+)$/) {
  292:                             my $grpstart = $3;
  293:                             my $grpend = $2;
  294:                             $currpriv{$group} = $1;
  295:                             if ($chgtype eq 'drop') {
  296:                                 if ($grpstart == -1) { next; } # deleted
  297:                                 if ($grpend == 0 || $grpend > $now) {
  298:                                     unless (defined($dropgroup{$group})) {
  299:                                         $dropstart{$group} = $grpstart;
  300:                                         if ($grpstart > $now) {
  301:                                             $dropstart{$group} = $now;
  302:                                         }
  303:                                         $dropgroup{$group} = $now.':'.
  304:                                                             $dropstart{$group}.
  305:                                                          ':'.$currpriv{$group};
  306:                                     }
  307:                                 }
  308:                             } elsif ($chgtype eq 'add') {
  309:                                 if (($grpstart == -1) || ($grpend > 0 &&
  310:                                      ($grpend < $settings{$group}{'enddate'} ||
  311:                                       $settings{$group}{'enddate'} == 0)) ||
  312:                                      ($grpstart > $settings{$group}{'startdate'})) {
  313:                                     unless(defined($addgroup{$group})) {
  314:                                         $addgroup{$group} =
  315:                                             $settings{$group}{'enddate'}.':'.
  316:                                             $settings{$group}{'startdate'}.':'.
  317:                                             $group_privs;
  318:                                     }
  319:                                 }
  320:                             }
  321:                         }
  322:                     } elsif ($chgtype eq 'add') {
  323:                         $addgroup{$group} = $settings{$group}{'enddate'}.':'.
  324:                                             $settings{$group}{'startdate'}.':'.
  325:                                             $group_privs;
  326:                     }
  327:                 }
  328:                 if ($chgtype eq 'add') {
  329:                     foreach my $add (keys(%addgroup)) {
  330:                         if (&Apache::lonnet::modify_group_roles($cdom,$cnum,
  331:                                                   $add,$uname.':'.$udom,
  332:                                                   $settings{$add}{'enddate'},
  333:                                                   $settings{$add}{'startdate'},
  334:                                                   $group_privs) eq 'ok') {
  335:                             my %usersettings;
  336:                             $usersettings{$add.':'.$uname.':'.$udom} =
  337:                                                                $addgroup{$add};
  338:                             my $roster_result =
  339:                                &Apache::lonnet::modify_coursegroup_membership(
  340:                                                    $cdom,$cnum,\%usersettings);
  341:                         }
  342:                     }
  343:                 } elsif ($chgtype eq 'drop') {
  344:                     foreach my $drop (keys(%dropgroup)) {
  345:                         my $nodrop = 0;
  346:                         if ($settings{$drop}{'autoadd'} eq 'on') {
  347:                             foreach my $urole (keys(%{$settings{$drop}{'autosec'}})) {
  348:                                 if ($nodrop) {
  349:                                     last;
  350:                                 } else {
  351:                                     my @autosec = ();
  352:                                     if (ref($settings{$drop}{'autosec'}{$urole}) eq 'ARRAY') {
  353:                                         @autosec = @{$settings{$drop}{'autosec'}{$urole}};
  354:                                     }
  355:                                     foreach my $usec (@autosec) {
  356:                                         if ($usec eq 'all') {
  357:                                             foreach my $ukey (keys(%roleshash)) {
  358:                                                 if ($ukey =~ /^\Q$cid\E(\/?\w*)_($urole)$/) {
  359:                                                     unless ($sec eq $1) {
  360:                                                         if ($roleshash{$ukey} =~ /_?(\d*)_?([\-\d]*)$/) {
  361:                                                             my $roleend = $1;
  362:                                                             if ((!$roleend) ||
  363:                                                                 ($roleend > $now)) {
  364:                                                                 $nodrop = 1;
  365:                                                                 last;
  366:                                                             }
  367:                                                         }
  368:                                                     }
  369:                                                 }
  370:                                             }
  371:                                         } else {
  372:                                             my $ukey = $cid.'/'.$usec.'_'.$urole;
  373:                                             if ($usec eq 'none') {
  374:                                                 if ($sec eq '') {
  375:                                                     next;
  376:                                                 }
  377:                                             } else {
  378:                                                 if ($usec eq $sec) {
  379:                                                     next;
  380:                                                 }
  381:                                             }
  382:                                             if (exists($roleshash{$ukey})) {
  383:                                                 if ($roleshash{$ukey} =~
  384:                                                        /_?(\d*)_?([\-\d]*)$/) {
  385:                                                     my $roleend = $1;
  386:                                                     if ((!$roleend) ||
  387:                                                         ($roleend > $now)) {
  388:                                                         $nodrop = 1;
  389:                                                         last;
  390:                                                     }
  391:                                                 }
  392:                                             }
  393:                                         }
  394:                                     }
  395:                                 }
  396:                             }
  397:                         }
  398:                         if (!$nodrop) {
  399:                             if (&Apache::lonnet::modify_group_roles($cdom,
  400:                                                          $cnum,$drop,
  401:                                                          $uname.':'.$udom,$now,
  402:                                                          $dropstart{$drop},
  403:                                                          $currpriv{$drop}) 
  404:                                                                      eq 'ok') {
  405:                                 my %usersettings;
  406:                                 $usersettings{$drop.':'.$uname.':'.$udom} =
  407:                                                              $dropgroup{$drop};
  408:                                 my $roster_result =
  409:                                 &Apache::lonnet::modify_coursegroup_membership(
  410:                                                    $cdom,$cnum,\%usersettings);
  411:                             }
  412:                         }
  413:                     }
  414:                 }
  415:             }
  416:         }
  417:     }
  418:     return;
  419: }
  420: 
  421: ###############################################
  422: 
  423: 1;
  424: