Annotation of loncom/Lond.pm, revision 1.8

1.1       droeschl    1: # The LearningOnline Network
                      2: #
1.8     ! raeburn     3: # $Id: Lond.pm,v 1.7 2015/05/21 23:40:17 raeburn Exp $
1.1       droeschl    4: #
                      5: # Copyright Michigan State University Board of Trustees
                      6: #
                      7: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      8: #
                      9: # LON-CAPA is free software; you can redistribute it and/or modify
                     10: # it under the terms of the GNU General Public License as published by
                     11: # the Free Software Foundation; either version 2 of the License, or
                     12: # (at your option) any later version.
                     13: #
                     14: # LON-CAPA is distributed in the hope that it will be useful,
                     15: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     16: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     17: # GNU General Public License for more details.
                     18: #
                     19: # You should have received a copy of the GNU General Public License
                     20: # along with LON-CAPA; if not, write to the Free Software
                     21: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     22: #
                     23: # /home/httpd/html/adm/gpl.txt
                     24: #
                     25: # http://www.lon-capa.org/
                     26: #
                     27: ###
                     28: 
                     29: #NOTE perldoc at the end of file
1.4       droeschl   30: #TODO move remaining lond functions into this
1.1       droeschl   31: 
                     32: package LONCAPA::Lond;
                     33: 
                     34: use strict;
                     35: use lib '/home/httpd/lib/perl/';
                     36: 
                     37: use LONCAPA;
                     38: use Apache::lonnet;
                     39: use GDBM_File;
                     40: 
                     41: 
                     42: sub dump_with_regexp {
1.4       droeschl   43:     my ( $tail, $clientversion ) = @_;
1.2       droeschl   44:     my ( $udom, $uname, $namespace, $regexp, $range ) = 
                     45:         split /:/, $tail;
1.1       droeschl   46: 
1.4       droeschl   47:     $regexp = $regexp ? unescape($regexp) : '.';
1.1       droeschl   48: 
                     49:     my ($start,$end);
1.2       droeschl   50: 
1.1       droeschl   51:     if (defined($range)) {
1.2       droeschl   52:         if ($range =~ /^(\d+)\-(\d+)$/) {
                     53:             ($start,$end) = ($1,$2);
                     54:         } elsif ($range =~/^(\d+)$/) {
                     55:             ($start,$end) = (0,$1);
                     56:         } else {
                     57:             undef($range);
                     58:         }
                     59:     }
                     60: 
                     61:     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or 
                     62:         return "error: ".($!+0)." tie(GDBM) Failed while attempting dump";
                     63: 
                     64:     my $qresult = '';
                     65:     my $count = 0;
1.1       droeschl   66: #
                     67: # When dump is for roles.db, determine if LON-CAPA version checking is needed.
1.2       droeschl   68: # Sessions on 2.10 and later do not require version checking, as that occurs
1.1       droeschl   69: # on the server hosting the user session, when constructing the roles/courses 
                     70: # screen).
                     71: # 
1.2       droeschl   72:     my $skipcheck;
                     73:     my @ids = &Apache::lonnet::current_machine_ids();
                     74:     my (%homecourses, $major, $minor, $now);
1.1       droeschl   75: # 
                     76: # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA   
1.2       droeschl   77: # version on the server which requested the data. 
1.1       droeschl   78: # 
1.2       droeschl   79:     if ($namespace eq 'roles') {
                     80:         if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
                     81:             $major = $1;
                     82:             $minor = $2;
1.4       droeschl   83: 
1.2       droeschl   84:         }
                     85:         if (($major > 2) || (($major == 2) && ($minor > 9))) {
                     86:             $skipcheck = 1;
1.1       droeschl   87:         }
1.2       droeschl   88:         $now = time;
                     89:     }
                     90:     while (my ($key,$value) = each(%$hashref)) {
                     91:             if ($namespace eq 'roles' && (!$skipcheck)) {
1.1       droeschl   92:                 if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
                     93:                     my $cdom = $1;
                     94:                     my $cnum = $2;
1.2       droeschl   95:                     my ($role,$roleend,$rolestart) = split(/\_/,$value);
                     96:                     if (!$roleend || $roleend > $now) {
1.1       droeschl   97: #
                     98: # For active course roles, check that requesting server is running a LON-CAPA
                     99: # version which meets any version requirements for the course. Do not include
                    100: # the role amongst the results returned if the requesting server's version is
                    101: # too old.
                    102: #
                    103: # This determination is handled differently depending on whether the course's 
                    104: # homeserver is the current server, or whether it is a different server.
                    105: # In both cases, the course's version requirement needs to be retrieved.
                    106: # 
1.2       droeschl  107:                         next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
                    108:                                                         $minor,\%homecourses,\@ids));
1.1       droeschl  109:                     }
                    110:                 }
                    111:             }
1.2       droeschl  112:         if ($regexp eq '.') {
                    113:             $count++;
                    114:             if (defined($range) && $count >= $end)   { last; }
                    115:             if (defined($range) && $count <  $start) { next; }
                    116:             $qresult.=$key.'='.$value.'&';
                    117:         } else {
                    118:             my $unescapeKey = &unescape($key);
                    119:             if (eval('$unescapeKey=~/$regexp/')) {
                    120:                 $count++;
                    121:                 if (defined($range) && $count >= $end)   { last; }
                    122:                 if (defined($range) && $count <  $start) { next; }
                    123:                 $qresult.="$key=$value&";
                    124:             }
                    125:         }
                    126:     }
                    127: 
                    128:     &untie_user_hash($hashref) or 
                    129:         return "error: ".($!+0)." untie(GDBM) Failed while attempting dump";
1.1       droeschl  130: #
                    131: # If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA
                    132: # version requirements for courses for which the current server is the home
                    133: # server permit course roles to be usable on the client server hosting the
                    134: # user's session. If so, include those role results in the data returned to  
                    135: # the client server.
                    136: #
1.2       droeschl  137:     if (($namespace eq 'roles') && (!$skipcheck)) {
                    138:         if (keys(%homecourses) > 0) {
                    139:             $qresult .= &check_homecourses(\%homecourses,$regexp,$count,
                    140:                                            $range,$start,$end,$major,$minor);
                    141:         }
                    142:     }
                    143:     chop($qresult);
                    144:     return $qresult;
                    145: }
                    146: 
                    147: 
                    148: sub releasereqd_check {
                    149:     my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
                    150:     my $home = &Apache::lonnet::homeserver($cnum,$cdom);
                    151:     return if ($home eq 'no_host');
                    152:     my ($reqdmajor,$reqdminor,$displayrole);
                    153:     if ($cnum =~ /$LONCAPA::match_community/) {
                    154:         if ($major eq '' && $minor eq '') {
                    155:             return unless ((ref($ids) eq 'ARRAY') && 
                    156:                            (grep(/^\Q$home\E$/,@{$ids})));
                    157:         } else {
                    158:             $reqdmajor = 2;
                    159:             $reqdminor = 9;
                    160:             return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
                    161:         }
                    162:     }
                    163:     my $hashid = $cdom.':'.$cnum;
                    164:     my ($courseinfo,$cached) =
                    165:         &Apache::lonnet::is_cached_new('courseinfo',$hashid);
                    166:     if (defined($cached)) {
                    167:         if (ref($courseinfo) eq 'HASH') {
                    168:             if (exists($courseinfo->{'releaserequired'})) {
                    169:                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
                    170:                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
                    171:             }
                    172:         }
                    173:     } else {
                    174:         if (ref($ids) eq 'ARRAY') {
                    175:             if (grep(/^\Q$home\E$/,@{$ids})) {
                    176:                 if (ref($homecourses) eq 'HASH') {
                    177:                     if (ref($homecourses->{$cdom}) eq 'HASH') {
                    178:                         if (ref($homecourses->{$cdom}{$cnum}) eq 'HASH') {
                    179:                             if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
                    180:                                 push(@{$homecourses->{$cdom}{$cnum}},{$key=>$value});
                    181:                             } else {
                    182:                                 $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
                    183:                             }
                    184:                         } else {
                    185:                             $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
                    186:                         }
                    187:                     } else {
                    188:                         $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
                    189:                     }
                    190:                 }
                    191:                 return;
                    192:             }
                    193:         }
                    194:         my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
                    195:         if (ref($courseinfo) eq 'HASH') {
                    196:             if (exists($courseinfo->{'releaserequired'})) {
                    197:                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
                    198:                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
                    199:             }
                    200:         } else {
                    201:             return;
                    202:         }
                    203:     }
                    204:     return 1;
                    205: }
                    206: 
                    207: 
                    208: sub check_homecourses {
                    209:     my ($homecourses,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
                    210:     my ($result,%addtocache);
                    211:     my $yesterday = time - 24*3600; 
                    212:     if (ref($homecourses) eq 'HASH') {
                    213:         my (%okcourses,%courseinfo,%recent);
                    214:         foreach my $domain (keys(%{$homecourses})) {
                    215:             my $hashref = 
                    216:                 &tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT());
                    217:             if (ref($hashref) eq 'HASH') {
                    218:                 while (my ($key,$value) = each(%$hashref)) {
                    219:                     my $unesc_key = &unescape($key);
                    220:                     if ($unesc_key =~ /^lasttime:(\w+)$/) {
                    221:                         my $cid = $1;
                    222:                         $cid =~ s/_/:/;
                    223:                         if ($value > $yesterday ) {
                    224:                             $recent{$cid} = 1;
                    225:                         }
                    226:                         next;
                    227:                     }
                    228:                     my $items = &Apache::lonnet::thaw_unescape($value);
                    229:                     if (ref($items) eq 'HASH') {
                    230:                         my ($cdom,$cnum) = split(/_/,$unesc_key);
                    231:                         my $hashid = $cdom.':'.$cnum; 
                    232:                         $courseinfo{$hashid} = $items;
                    233:                         if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
                    234:                             my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
                    235:                             if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
                    236:                                $okcourses{$hashid} = 1;
                    237:                             }
                    238:                         }
                    239:                     }
                    240:                 }
                    241:                 unless (&untie_domain_hash($hashref)) {
                    242:                     &logthis("Failed to untie tied hash for nohist_courseids.db for $domain");
                    243:                 }
                    244:             } else {
                    245:                 &logthis("Failed to tie hash for nohist_courseids.db for $domain");
                    246:             }
                    247:         }
                    248:         foreach my $hashid (keys(%recent)) {
                    249:             my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
                    250:             unless ($cached) {
                    251:                 &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
                    252:             }
                    253:         }
                    254:         foreach my $cdom (keys(%{$homecourses})) {
                    255:             if (ref($homecourses->{$cdom}) eq 'HASH') {
                    256:                 foreach my $cnum (keys(%{$homecourses->{$cdom}})) {
                    257:                     my $hashid = $cdom.':'.$cnum;
                    258:                     next if ($recent{$hashid});
                    259:                     &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
                    260:                 }
                    261:             }
                    262:         }
                    263:         foreach my $hashid (keys(%okcourses)) {
                    264:             my ($cdom,$cnum) = split(/:/,$hashid);
                    265:             if ((ref($homecourses->{$cdom}) eq 'HASH') &&  
                    266:                 (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) {
                    267:                 foreach my $role (@{$homecourses->{$cdom}{$cnum}}) {
                    268:                     if (ref($role) eq 'HASH') {
                    269:                         while (my ($key,$value) = each(%{$role})) {
                    270:                             if ($regexp eq '.') {
                    271:                                 $count++;
                    272:                                 if (defined($range) && $count >= $end)   { last; }
                    273:                                 if (defined($range) && $count <  $start) { next; }
                    274:                                 $result.=$key.'='.$value.'&';
                    275:                             } else {
                    276:                                 my $unescapeKey = &unescape($key);
                    277:                                 if (eval('$unescapeKey=~/$regexp/')) {
                    278:                                     $count++;
                    279:                                     if (defined($range) && $count >= $end)   { last; }
                    280:                                     if (defined($range) && $count <  $start) { next; }
                    281:                                     $result.="$key=$value&";
                    282:                                 }
                    283:                             }
                    284:                         }
                    285:                     }
1.1       droeschl  286:                 }
                    287:             }
1.2       droeschl  288:         }
1.1       droeschl  289:     }
1.2       droeschl  290:     return $result;
                    291: }
                    292: 
1.1       droeschl  293: 
1.2       droeschl  294: sub useable_role {
                    295:     my ($reqdmajor,$reqdminor,$major,$minor) = @_; 
                    296:     if ($reqdmajor ne '' && $reqdminor ne '') {
                    297:         return if (($major eq '' && $minor eq '') ||
                    298:                    ($major < $reqdmajor) ||
                    299:                    (($major == $reqdmajor) && ($minor < $reqdminor)));
                    300:     }
1.1       droeschl  301:     return 1;
                    302: }
                    303: 
1.2       droeschl  304: 
1.3       droeschl  305: sub get_courseinfo_hash {
                    306:     my ($cnum,$cdom,$home) = @_;
                    307:     my %info;
                    308:     eval {
                    309:         local($SIG{ALRM}) = sub { die "timeout\n"; };
                    310:         local($SIG{__DIE__})='DEFAULT';
                    311:         alarm(3);
                    312:         %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
                    313:         alarm(0);
                    314:     };
                    315:     if ($@) {
                    316:         if ($@ eq "timeout\n") {
                    317:             &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
                    318:         } else {
                    319:             &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
                    320:         }
                    321:     } else {
                    322:         if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
                    323:             my $hashid = $cdom.':'.$cnum;
                    324:             return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
                    325:         }
                    326:     }
                    327:     return;
                    328: }
1.2       droeschl  329: 
1.4       droeschl  330: sub dump_course_id_handler {
                    331:     my ($tail) = @_;
                    332: 
                    333:     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
                    334:         $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
                    335:         $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
1.7       raeburn   336:         $creationcontext,$domcloner,$hasuniquecode,$reqcrsdom,$reqinstcode) = split(/:/,$tail);
1.4       droeschl  337:     my $now = time;
                    338:     my ($cloneruname,$clonerudom,%cc_clone);
                    339:     if (defined($description)) {
                    340: 	$description=&unescape($description);
                    341:     } else {
                    342: 	$description='.';
                    343:     }
                    344:     if (defined($instcodefilter)) {
                    345:         $instcodefilter=&unescape($instcodefilter);
                    346:     } else {
                    347:         $instcodefilter='.';
                    348:     }
                    349:     my ($ownerunamefilter,$ownerdomfilter);
                    350:     if (defined($ownerfilter)) {
                    351:         $ownerfilter=&unescape($ownerfilter);
                    352:         if ($ownerfilter ne '.' && defined($ownerfilter)) {
                    353:             if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
                    354:                  $ownerunamefilter = $1;
                    355:                  $ownerdomfilter = $2;
                    356:             } else {
                    357:                 $ownerunamefilter = $ownerfilter;
                    358:                 $ownerdomfilter = '';
                    359:             }
                    360:         }
                    361:     } else {
                    362:         $ownerfilter='.';
                    363:     }
                    364: 
                    365:     if (defined($coursefilter)) {
                    366:         $coursefilter=&unescape($coursefilter);
                    367:     } else {
                    368:         $coursefilter='.';
                    369:     }
                    370:     if (defined($typefilter)) {
                    371:         $typefilter=&unescape($typefilter);
                    372:     } else {
                    373:         $typefilter='.';
                    374:     }
                    375:     if (defined($regexp_ok)) {
                    376:         $regexp_ok=&unescape($regexp_ok);
                    377:     }
                    378:     if (defined($catfilter)) {
                    379:         $catfilter=&unescape($catfilter);
                    380:     }
                    381:     if (defined($cloner)) {
                    382:         $cloner = &unescape($cloner);
                    383:         ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); 
                    384:     }
                    385:     if (defined($cc_clone_list)) {
                    386:         $cc_clone_list = &unescape($cc_clone_list);
                    387:         my @cc_cloners = split('&',$cc_clone_list);
                    388:         foreach my $cid (@cc_cloners) {
                    389:             my ($clonedom,$clonenum) = split(':',$cid);
                    390:             next if ($clonedom ne $udom); 
                    391:             $cc_clone{$clonedom.'_'.$clonenum} = 1;
                    392:         } 
                    393:     }
                    394:     if ($createdbefore ne '') {
                    395:         $createdbefore = &unescape($createdbefore);
                    396:     } else {
                    397:        $createdbefore = 0;
                    398:     }
                    399:     if ($createdafter ne '') {
                    400:         $createdafter = &unescape($createdafter);
                    401:     } else {
                    402:         $createdafter = 0;
                    403:     }
                    404:     if ($creationcontext ne '') {
                    405:         $creationcontext = &unescape($creationcontext);
                    406:     } else {
                    407:         $creationcontext = '.';
                    408:     }
1.6       raeburn   409:     unless ($hasuniquecode) {
                    410:         $hasuniquecode = '.';
                    411:     }
1.8     ! raeburn   412:     if ($reqinstcode ne '') {
        !           413:         $reqinstcode = &unescape($reqinstcode);
        !           414:     }
1.4       droeschl  415:     my $unpack = 1;
                    416:     if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && 
                    417:         $typefilter eq '.') {
                    418:         $unpack = 0;
                    419:     }
                    420:     if (!defined($since)) { $since=0; }
1.7       raeburn   421:     my (%gotcodedefaults,%otcodedefaults);
1.4       droeschl  422:     my $qresult='';
                    423: 
                    424:     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT())
                    425:         or return "error: ".($!+0)." tie(GDBM) Failed while attempting courseiddump";
                    426: 
                    427: 	while (my ($key,$value) = each(%$hashref)) {
                    428:             my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
                    429:                 %unesc_val,$selfenroll_end,$selfenroll_types,$created,
                    430:                 $context);
                    431:             $unesc_key = &unescape($key);
                    432:             if ($unesc_key =~ /^lasttime:/) {
                    433:                 next;
                    434:             } else {
                    435:                 $lasttime_key = &escape('lasttime:'.$unesc_key);
                    436:             }
                    437:             if ($hashref->{$lasttime_key} ne '') {
                    438:                 $lasttime = $hashref->{$lasttime_key};
                    439:                 next if ($lasttime<$since);
                    440:             }
1.7       raeburn   441:             my ($canclone,$valchange,$clonefromcode);
1.4       droeschl  442:             my $items = &Apache::lonnet::thaw_unescape($value);
                    443:             if (ref($items) eq 'HASH') {
                    444:                 if ($hashref->{$lasttime_key} eq '') {
                    445:                     next if ($since > 1);
                    446:                 }
1.7       raeburn   447:                 if ($items->{'inst_code'}) {
                    448:                     $clonefromcode = $items->{'inst_code'};
                    449:                 }
1.4       droeschl  450:                 $is_hash =  1;
                    451:                 if ($domcloner) {
                    452:                     $canclone = 1;
                    453:                 } elsif (defined($clonerudom)) {
                    454:                     if ($items->{'cloners'}) {
                    455:                         my @cloneable = split(',',$items->{'cloners'});
                    456:                         if (@cloneable) {
                    457:                             if (grep(/^\*$/,@cloneable))  {
                    458:                                 $canclone = 1;
                    459:                             } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
                    460:                                 $canclone = 1;
                    461:                             } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
                    462:                                 $canclone = 1;
                    463:                             }
                    464:                         }
                    465:                         unless ($canclone) {
                    466:                             if ($cloneruname ne '' && $clonerudom ne '') {
                    467:                                 if ($cc_clone{$unesc_key}) {
                    468:                                     $canclone = 1;
                    469:                                     $items->{'cloners'} .= ','.$cloneruname.':'.
                    470:                                                            $clonerudom;
                    471:                                     $valchange = 1;
                    472:                                 }
                    473:                             }
                    474:                         }
1.7       raeburn   475:                         unless ($canclone) {
                    476:                             if (($reqcrsdom eq $udom) && ($reqinstcode) && ($clonefromcode)) {
                    477:                                 if (grep(/\=/,@cloneable))  {
                    478:                                     foreach my $cloner (@cloneable) {
                    479:                                         if (($cloner ne '*') && ($cloner !~ /^\*\:$LONCAPA::match_domain$/) &&
                    480:                                             ($cloner !~ /^$LONCAPA::match_username\:$LONCAPA::match_domain$/) && ($cloner ne '')) {
                    481:                                             if ($cloner =~ /=/) {
                    482:                                                 my (%codedefaults,@code_order);
                    483:                                                 if (ref($gotcodedefaults{$udom}) eq 'HASH') {
                    484:                                                     if (ref($gotcodedefaults{$udom}{'defaults'}) eq 'HASH') {
                    485:                                                         %codedefaults = %{$gotcodedefaults{$udom}{'defaults'}};
                    486:                                                     }
                    487:                                                     if (ref($gotcodedefaults{$udom}{'order'}) eq 'ARRAY') {
                    488:                                                         @code_order = @{$gotcodedefaults{$udom}{'order'}};
                    489:                                                     }
                    490:                                                 } else {
                    491:                                                     &Apache::lonnet::auto_instcode_defaults($udom,
                    492:                                                                                             \%codedefaults,
                    493:                                                                                             \@code_order);
                    494:                                                     $gotcodedefaults{$udom}{'defaults'} = \%codedefaults;
                    495:                                                     $gotcodedefaults{$udom}{'order'} = \@code_order;
                    496:                                                 }
                    497:                                                 if (@code_order > 0) {
                    498:                                                     if (&Apache::lonnet::check_instcode_cloning(\%codedefaults,\@code_order,
                    499:                                                                                                 $cloner,$clonefromcode,$reqinstcode)) {
                    500:                                                         $canclone = 1;
                    501:                                                         last;
                    502:                                                     }
                    503:                                                 }
                    504:                                             }
                    505:                                         }
                    506:                                     }
                    507:                                 }
                    508:                             }
                    509:                         }
1.4       droeschl  510:                     } elsif (defined($cloneruname)) {
                    511:                         if ($cc_clone{$unesc_key}) {
                    512:                             $canclone = 1;
                    513:                             $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                    514:                             $valchange = 1;
                    515:                         }
                    516:                         unless ($canclone) {
                    517:                             if ($items->{'owner'} =~ /:/) {
                    518:                                 if ($items->{'owner'} eq $cloner) {
                    519:                                     $canclone = 1;
                    520:                                 }
                    521:                             } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
                    522:                                 $canclone = 1;
                    523:                             }
                    524:                             if ($canclone) {
                    525:                                 $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                    526:                                 $valchange = 1;
                    527:                             }
                    528:                         }
                    529:                     }
1.7       raeburn   530:                     unless (($canclone) || ($items->{'cloners'})) {
                    531:                         my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
                    532:                         if ($domdefs{'canclone'}) {
                    533:                             unless ($domdefs{'canclone'} eq 'none') {
                    534:                                 if ($domdefs{'canclone'} eq 'domain') {
                    535:                                     if ($clonerudom eq $udom) {
                    536:                                         $canclone = 1;
                    537:                                     }
                    538:                                 } elsif (($clonefromcode) && ($reqinstcode) &&
                    539:                                          ($udom eq $reqcrsdom)) {
                    540:                                     if (&Apache::lonnet::default_instcode_cloning($udom,$domdefs{'canclone'},
                    541:                                                                                   $clonefromcode,$reqinstcode)) {
                    542:                                         $canclone = 1;
                    543:                                     }
                    544:                                 }
                    545:                             }
                    546:                         }
                    547:                     }
1.4       droeschl  548:                 }
                    549:                 if ($unpack || !$rtn_as_hash) {
                    550:                     $unesc_val{'descr'} = $items->{'description'};
                    551:                     $unesc_val{'inst_code'} = $items->{'inst_code'};
                    552:                     $unesc_val{'owner'} = $items->{'owner'};
                    553:                     $unesc_val{'type'} = $items->{'type'};
                    554:                     $unesc_val{'cloners'} = $items->{'cloners'};
                    555:                     $unesc_val{'created'} = $items->{'created'};
                    556:                     $unesc_val{'context'} = $items->{'context'};
                    557:                 }
                    558:                 $selfenroll_types = $items->{'selfenroll_types'};
                    559:                 $selfenroll_end = $items->{'selfenroll_end_date'};
                    560:                 $created = $items->{'created'};
                    561:                 $context = $items->{'context'};
                    562:                 if ($selfenrollonly) {
                    563:                     next if (!$selfenroll_types);
                    564:                     if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
                    565:                         next;
                    566:                     }
                    567:                 }
                    568:                 if ($creationcontext ne '.') {
                    569:                     next if (($context ne '') && ($context ne $creationcontext));  
                    570:                 }
                    571:                 if ($createdbefore > 0) {
                    572:                     next if (($created eq '') || ($created > $createdbefore));   
                    573:                 }
                    574:                 if ($createdafter > 0) {
                    575:                     next if (($created eq '') || ($created <= $createdafter)); 
                    576:                 }
                    577:                 if ($catfilter ne '') {
                    578:                     next if ($items->{'categories'} eq '');
                    579:                     my @categories = split('&',$items->{'categories'}); 
                    580:                     next if (@categories == 0);
                    581:                     my @subcats = split('&',$catfilter);
                    582:                     my $matchcat = 0;
                    583:                     foreach my $cat (@categories) {
                    584:                         if (grep(/^\Q$cat\E$/,@subcats)) {
                    585:                             $matchcat = 1;
                    586:                             last;
                    587:                         }
                    588:                     }
                    589:                     next if (!$matchcat);
                    590:                 }
                    591:                 if ($caller eq 'coursecatalog') {
                    592:                     if ($items->{'hidefromcat'} eq 'yes') {
                    593:                         next if !$showhidden;
                    594:                     }
                    595:                 }
1.6       raeburn   596:                 if ($hasuniquecode ne '.') {
                    597:                     next unless ($items->{'uniquecode'});
                    598:                 }
1.4       droeschl  599:             } else {
                    600:                 next if ($catfilter ne '');
                    601:                 next if ($selfenrollonly);
                    602:                 next if ($createdbefore || $createdafter);
                    603:                 next if ($creationcontext ne '.');
                    604:                 if ((defined($clonerudom)) && (defined($cloneruname)))  {
                    605:                     if ($cc_clone{$unesc_key}) {
                    606:                         $canclone = 1;
                    607:                         $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
                    608:                     }
                    609:                 }
                    610:                 $is_hash =  0;
                    611:                 my @courseitems = split(/:/,$value);
                    612:                 $lasttime = pop(@courseitems);
                    613:                 if ($hashref->{$lasttime_key} eq '') {
                    614:                     next if ($lasttime<$since);
                    615:                 }
                    616: 	        ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
                    617:             }
                    618:             if ($cloneonly) {
                    619:                next unless ($canclone);
                    620:             }
                    621:             my $match = 1;
                    622: 	    if ($description ne '.') {
                    623:                 if (!$is_hash) {
                    624:                     $unesc_val{'descr'} = &unescape($val{'descr'});
                    625:                 }
                    626:                 if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
                    627:                     $match = 0;
                    628:                 }
                    629:             }
                    630:             if ($instcodefilter ne '.') {
                    631:                 if (!$is_hash) {
                    632:                     $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                    633:                 }
                    634:                 if ($regexp_ok == 1) {
                    635:                     if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                    636:                         $match = 0;
                    637:                     }
                    638:                 } elsif ($regexp_ok == -1) {
                    639:                     if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
                    640:                         $match = 0;
                    641:                     }
                    642:                 } else {
                    643:                     if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                    644:                         $match = 0;
                    645:                     }
                    646:                 }
                    647: 	    }
                    648:             if ($ownerfilter ne '.') {
                    649:                 if (!$is_hash) {
                    650:                     $unesc_val{'owner'} = &unescape($val{'owner'});
                    651:                 }
                    652:                 if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
                    653:                     if ($unesc_val{'owner'} =~ /:/) {
                    654:                         if (eval{$unesc_val{'owner'} !~ 
                    655:                              /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
                    656:                             $match = 0;
                    657:                         } 
                    658:                     } else {
                    659:                         if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                    660:                             $match = 0;
                    661:                         }
                    662:                     }
                    663:                 } elsif ($ownerunamefilter ne '') {
                    664:                     if ($unesc_val{'owner'} =~ /:/) {
                    665:                         if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
                    666:                              $match = 0;
                    667:                         }
                    668:                     } else {
                    669:                         if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                    670:                             $match = 0;
                    671:                         }
                    672:                     }
                    673:                 } elsif ($ownerdomfilter ne '') {
                    674:                     if ($unesc_val{'owner'} =~ /:/) {
                    675:                         if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
                    676:                              $match = 0;
                    677:                         }
                    678:                     } else {
                    679:                         if ($ownerdomfilter ne $udom) {
                    680:                             $match = 0;
                    681:                         }
                    682:                     }
                    683:                 }
                    684:             }
                    685:             if ($coursefilter ne '.') {
                    686:                 if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
                    687:                     $match = 0;
                    688:                 }
                    689:             }
                    690:             if ($typefilter ne '.') {
                    691:                 if (!$is_hash) {
                    692:                     $unesc_val{'type'} = &unescape($val{'type'});
                    693:                 }
                    694:                 if ($unesc_val{'type'} eq '') {
                    695:                     if ($typefilter ne 'Course') {
                    696:                         $match = 0;
                    697:                     }
                    698:                 } else {
                    699:                     if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
                    700:                         $match = 0;
                    701:                     }
                    702:                 }
                    703:             }
                    704:             if ($match == 1) {
                    705:                 if ($rtn_as_hash) {
                    706:                     if ($is_hash) {
                    707:                         if ($valchange) {
                    708:                             my $newvalue = &Apache::lonnet::freeze_escape($items);
                    709:                             $qresult.=$key.'='.$newvalue.'&';
                    710:                         } else {
                    711:                             $qresult.=$key.'='.$value.'&';
                    712:                         }
                    713:                     } else {
                    714:                         my %rtnhash = ( 'description' => &unescape($val{'descr'}),
                    715:                                         'inst_code' => &unescape($val{'inst_code'}),
                    716:                                         'owner'     => &unescape($val{'owner'}),
                    717:                                         'type'      => &unescape($val{'type'}),
                    718:                                         'cloners'   => &unescape($val{'cloners'}),
                    719:                                       );
                    720:                         my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
                    721:                         $qresult.=$key.'='.$items.'&';
                    722:                     }
                    723:                 } else {
                    724:                     if ($is_hash) {
                    725:                         $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
                    726:                                     &escape($unesc_val{'inst_code'}).':'.
                    727:                                     &escape($unesc_val{'owner'}).'&';
                    728:                     } else {
                    729:                         $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
                    730:                                     ':'.$val{'owner'}.'&';
                    731:                     }
                    732:                 }
                    733:             }
                    734: 	}
                    735:     &untie_domain_hash($hashref) or 
                    736:         return "error: ".($!+0)." untie(GDBM) Failed while attempting courseiddump";
                    737: 
                    738:     chop($qresult);
                    739:     return $qresult;
                    740: }
                    741: 
                    742: sub dump_profile_database {
                    743:     my ($tail) = @_;
                    744: 
                    745:     my ($udom,$uname,$namespace) = split(/:/,$tail);
                    746: 
                    747:     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or
                    748:         return "error: ".($!+0)." tie(GDBM) Failed while attempting currentdump";
                    749: 
                    750: 	# Structure of %data:
                    751: 	# $data{$symb}->{$parameter}=$value;
                    752: 	# $data{$symb}->{'v.'.$parameter}=$version;
                    753: 	# since $parameter will be unescaped, we do not
                    754:  	# have to worry about silly parameter names...
                    755: 	
                    756:         my $qresult='';
                    757: 	my %data = ();                     # A hash of anonymous hashes..
                    758: 	while (my ($key,$value) = each(%$hashref)) {
                    759: 	    my ($v,$symb,$param) = split(/:/,$key);
                    760: 	    next if ($v eq 'version' || $symb eq 'keys');
                    761: 	    next if (exists($data{$symb}) && 
                    762: 		     exists($data{$symb}->{$param}) &&
                    763: 		     $data{$symb}->{'v.'.$param} > $v);
                    764: 	    $data{$symb}->{$param}=$value;
                    765: 	    $data{$symb}->{'v.'.$param}=$v;
                    766: 	}
                    767: 
                    768:     &untie_user_hash($hashref) or
                    769:         return "error: ".($!+0)." untie(GDBM) Failed while attempting currentdump";
                    770: 
                    771:     while (my ($symb,$param_hash) = each(%data)) {
                    772:     while(my ($param,$value) = each (%$param_hash)){
                    773:         next if ($param =~ /^v\./);       # Ignore versions...
                    774:         #
                    775:         #   Just dump the symb=value pairs separated by &
                    776:         #
                    777:         $qresult.=$symb.':'.$param.'='.$value.'&';
                    778:     }
                    779:     }
1.2       droeschl  780: 
1.4       droeschl  781:     chop($qresult);
                    782:     return $qresult;
                    783: }
1.2       droeschl  784: 
                    785: 
1.1       droeschl  786: 1;
                    787: 
                    788: __END__
                    789: 
                    790: =head1 NAME
                    791: 
                    792: LONCAPA::Lond.pm
                    793: 
                    794: =head1 SYNOPSIS
                    795: 
                    796: #TODO
                    797: 
                    798: =head1 DESCRIPTION
                    799: 
                    800: #TODO
                    801: 
                    802: =head1 METHODS
                    803: 
                    804: =over 4
                    805: 
1.2       droeschl  806: =item dump_with_regexp( $tail, $client )
1.1       droeschl  807: 
                    808: Dump a profile database with an optional regular expression to match against
                    809: the keys.  In this dump, no effort is made to separate symb from version
                    810: information. Presumably the databases that are dumped by this command are of a
                    811: different structure.  Need to look at this and improve the documentation of
                    812: both this and the currentdump handler.
                    813: 
                    814: $tail a colon separated list containing
                    815: 
                    816: =over 
                    817: 
                    818: =item domain
                    819: 
                    820: =item user 
                    821: 
                    822: identifying the user.
                    823: 
                    824: =item namespace    
                    825: 
                    826: identifying the database.
                    827: 
                    828: =item regexp     
                    829: 
                    830: optional regular expression that is matched against database keywords to do
                    831: selective dumps.
                    832: 
                    833: =item range       
                    834: 
                    835: optional range of entries e.g., 10-20 would return the 10th to 19th items, etc.  
                    836: 
                    837: =back
                    838: 
                    839: $client is the channel open on the client.
                    840: 
                    841: Returns: 1 (Continue processing).
                    842: 
                    843: Side effects: response is written to $client.  
                    844: 
1.5       bisitz    845: =item dump_course_id_handler
1.4       droeschl  846: 
                    847: #TODO copy from lond
                    848: 
                    849: =item dump_profile_database
                    850: 
                    851: #TODO copy from lond  
1.2       droeschl  852: 
                    853: =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor, 
                    854:         $homecourses, $ids )
                    855: 
                    856: releasereqd_check() will determine if a LON-CAPA version (defined in the
                    857: $major,$minor args passed) is not too old to allow use of a role in a 
                    858: course ($cnum,$cdom args passed), if at least one of the following applies: 
                    859: (a) the course is a Community, (b) the course's home server is *not* the
                    860: current server, or (c) cached course information is not stale. 
                    861: 
                    862: For the case where none of these apply, the course is added to the 
                    863: $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
                    864: The $homecourse hash ref is for courses for which the current server is the 
                    865: home server.  LON-CAPA version requirements are checked elsewhere for the
                    866: items in $homecourse.
                    867: 
                    868: 
                    869: =item check_homecourses( $homecourses, $regexp, $count, $range, $start, $end, 
                    870:         $major, $minor )
                    871: 
                    872: check_homecourses() will retrieve course information for those courses which
                    873: are keys of the $homecourses hash ref (first arg). The nohist_courseids.db 
                    874: GDBM file is tied and course information for each course retrieved. Last   
                    875: visit (lasttime key) is also retrieved for each, and cached values updated  
                    876: for any courses last visited less than 24 hours ago. Cached values are also
                    877: updated for any courses included in the $homecourses hash ref.
                    878: 
                    879: The reason for the 24 hours constraint is that the cron entry in 
                    880: /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes 
                    881: cached course information to be updated nightly for courses with activity
                    882: within the past 24 hours.
                    883: 
                    884: Role information for the user (included in a ref to an array of hashes as the
                    885: value for each key in $homecourses) is appended to the result returned by the
                    886: routine, which will in turn be appended to the string returned to the client
                    887: hosting the user's session.
                    888: 
                    889: 
                    890: =item useable_role( $reqdmajor, $reqdminor, $major, $minor )
                    891: 
                    892: useable_role() will compare the LON-CAPA version required by a course with 
                    893: the version available on the client server.  If the client server's version
                    894: is compatible, 1 will be returned.
                    895: 
                    896: 
1.3       droeschl  897: =item get_courseinfo_hash( $cnum, $cdom, $home )
                    898: 
                    899: get_courseinfo_hash() is used to retrieve course information from the db
                    900: file: nohist_courseids.db for a course for which the current server is *not*
                    901: the home server.
                    902: 
                    903: A hash of a hash will be retrieved. The outer hash contains a single key --
                    904: courseID -- for the course for which the data are being requested.
                    905: The contents of the inner hash, for that single item in the outer hash
                    906: are returned (and cached in memcache for 10 minutes).
                    907: 
                    908: 
                    909: 
1.1       droeschl  910: =back
                    911: 
                    912: =head1 BUGS
                    913: 
                    914: No known bugs at this time.
                    915: 
                    916: =head1 SEE ALSO
                    917: 
                    918: L<Apache::lonnet>, L<lond>
                    919: 
                    920: =cut  

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>