Annotation of loncom/Lond.pm, revision 1.15

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

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