Annotation of loncom/Lond.pm, revision 1.9

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

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