Annotation of loncom/Lond.pm, revision 1.2

1.1       droeschl    1: # The LearningOnline Network
                      2: #
1.2     ! droeschl    3: # $Id: Lond.pm,v 1.1 2012/04/11 21:32:28 droeschl 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
                     30: 
                     31: package LONCAPA::Lond;
                     32: 
                     33: use strict;
                     34: use lib '/home/httpd/lib/perl/';
                     35: 
                     36: use LONCAPA;
                     37: use Apache::lonnet;
                     38: use GDBM_File;
                     39: 
                     40: 
                     41: sub dump_with_regexp {
1.2     ! droeschl   42:     my ( $tail, $clientname, $clientversion ) = @_;
        !            43:     my ( $udom, $uname, $namespace, $regexp, $range ) = 
        !            44:         split /:/, $tail;
1.1       droeschl   45: 
1.2     ! droeschl   46:     $regexp = defined $regexp ? unescape($regexp) : '.';
1.1       droeschl   47: 
                     48:     my ($start,$end);
1.2     ! droeschl   49: 
1.1       droeschl   50:     if (defined($range)) {
1.2     ! droeschl   51:         if ($range =~ /^(\d+)\-(\d+)$/) {
        !            52:             ($start,$end) = ($1,$2);
        !            53:         } elsif ($range =~/^(\d+)$/) {
        !            54:             ($start,$end) = (0,$1);
        !            55:         } else {
        !            56:             undef($range);
        !            57:         }
        !            58:     }
        !            59: 
        !            60:     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or 
        !            61:         return "error: ".($!+0)." tie(GDBM) Failed while attempting dump";
        !            62: 
        !            63:     my $qresult = '';
        !            64:     my $count = 0;
1.1       droeschl   65: #
                     66: # When dump is for roles.db, determine if LON-CAPA version checking is needed.
1.2     ! droeschl   67: # Sessions on 2.10 and later do not require version checking, as that occurs
1.1       droeschl   68: # on the server hosting the user session, when constructing the roles/courses 
                     69: # screen).
                     70: # 
1.2     ! droeschl   71:     my $skipcheck;
        !            72:     my @ids = &Apache::lonnet::current_machine_ids();
        !            73:     my (%homecourses, $major, $minor, $now);
1.1       droeschl   74: # 
                     75: # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA   
1.2     ! droeschl   76: # version on the server which requested the data. 
1.1       droeschl   77: # 
1.2     ! droeschl   78:     if ($namespace eq 'roles') {
        !            79:         if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
        !            80:             $major = $1;
        !            81:             $minor = $2;
        !            82:         }
        !            83:         if (($major > 2) || (($major == 2) && ($minor > 9))) {
        !            84:             $skipcheck = 1;
1.1       droeschl   85:         }
1.2     ! droeschl   86:         $now = time;
        !            87:     }
        !            88:     while (my ($key,$value) = each(%$hashref)) {
        !            89:             if ($namespace eq 'roles' && (!$skipcheck)) {
1.1       droeschl   90:                 if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
                     91:                     my $cdom = $1;
                     92:                     my $cnum = $2;
1.2     ! droeschl   93:                     my ($role,$roleend,$rolestart) = split(/\_/,$value);
        !            94:                     if (!$roleend || $roleend > $now) {
1.1       droeschl   95: #
                     96: # For active course roles, check that requesting server is running a LON-CAPA
                     97: # version which meets any version requirements for the course. Do not include
                     98: # the role amongst the results returned if the requesting server's version is
                     99: # too old.
                    100: #
                    101: # This determination is handled differently depending on whether the course's 
                    102: # homeserver is the current server, or whether it is a different server.
                    103: # In both cases, the course's version requirement needs to be retrieved.
                    104: # 
1.2     ! droeschl  105:                         next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
        !           106:                                                         $minor,\%homecourses,\@ids));
1.1       droeschl  107:                     }
                    108:                 }
                    109:             }
1.2     ! droeschl  110:         if ($regexp eq '.') {
        !           111:             $count++;
        !           112:             if (defined($range) && $count >= $end)   { last; }
        !           113:             if (defined($range) && $count <  $start) { next; }
        !           114:             $qresult.=$key.'='.$value.'&';
        !           115:         } else {
        !           116:             my $unescapeKey = &unescape($key);
        !           117:             if (eval('$unescapeKey=~/$regexp/')) {
        !           118:                 $count++;
        !           119:                 if (defined($range) && $count >= $end)   { last; }
        !           120:                 if (defined($range) && $count <  $start) { next; }
        !           121:                 $qresult.="$key=$value&";
        !           122:             }
        !           123:         }
        !           124:     }
        !           125: 
        !           126:     &untie_user_hash($hashref) or 
        !           127:         return "error: ".($!+0)." untie(GDBM) Failed while attempting dump";
1.1       droeschl  128: #
                    129: # If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA
                    130: # version requirements for courses for which the current server is the home
                    131: # server permit course roles to be usable on the client server hosting the
                    132: # user's session. If so, include those role results in the data returned to  
                    133: # the client server.
                    134: #
1.2     ! droeschl  135:     if (($namespace eq 'roles') && (!$skipcheck)) {
        !           136:         if (keys(%homecourses) > 0) {
        !           137:             $qresult .= &check_homecourses(\%homecourses,$regexp,$count,
        !           138:                                            $range,$start,$end,$major,$minor);
        !           139:         }
        !           140:     }
        !           141:     chop($qresult);
        !           142:     return $qresult;
        !           143: }
        !           144: 
        !           145: 
        !           146: sub releasereqd_check {
        !           147:     my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
        !           148:     my $home = &Apache::lonnet::homeserver($cnum,$cdom);
        !           149:     return if ($home eq 'no_host');
        !           150:     my ($reqdmajor,$reqdminor,$displayrole);
        !           151:     if ($cnum =~ /$LONCAPA::match_community/) {
        !           152:         if ($major eq '' && $minor eq '') {
        !           153:             return unless ((ref($ids) eq 'ARRAY') && 
        !           154:                            (grep(/^\Q$home\E$/,@{$ids})));
        !           155:         } else {
        !           156:             $reqdmajor = 2;
        !           157:             $reqdminor = 9;
        !           158:             return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
        !           159:         }
        !           160:     }
        !           161:     my $hashid = $cdom.':'.$cnum;
        !           162:     my ($courseinfo,$cached) =
        !           163:         &Apache::lonnet::is_cached_new('courseinfo',$hashid);
        !           164:     if (defined($cached)) {
        !           165:         if (ref($courseinfo) eq 'HASH') {
        !           166:             if (exists($courseinfo->{'releaserequired'})) {
        !           167:                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
        !           168:                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
        !           169:             }
        !           170:         }
        !           171:     } else {
        !           172:         if (ref($ids) eq 'ARRAY') {
        !           173:             if (grep(/^\Q$home\E$/,@{$ids})) {
        !           174:                 if (ref($homecourses) eq 'HASH') {
        !           175:                     if (ref($homecourses->{$cdom}) eq 'HASH') {
        !           176:                         if (ref($homecourses->{$cdom}{$cnum}) eq 'HASH') {
        !           177:                             if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
        !           178:                                 push(@{$homecourses->{$cdom}{$cnum}},{$key=>$value});
        !           179:                             } else {
        !           180:                                 $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
        !           181:                             }
        !           182:                         } else {
        !           183:                             $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
        !           184:                         }
        !           185:                     } else {
        !           186:                         $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
        !           187:                     }
        !           188:                 }
        !           189:                 return;
        !           190:             }
        !           191:         }
        !           192:         my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
        !           193:         if (ref($courseinfo) eq 'HASH') {
        !           194:             if (exists($courseinfo->{'releaserequired'})) {
        !           195:                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
        !           196:                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
        !           197:             }
        !           198:         } else {
        !           199:             return;
        !           200:         }
        !           201:     }
        !           202:     return 1;
        !           203: }
        !           204: 
        !           205: 
        !           206: sub check_homecourses {
        !           207:     my ($homecourses,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
        !           208:     my ($result,%addtocache);
        !           209:     my $yesterday = time - 24*3600; 
        !           210:     if (ref($homecourses) eq 'HASH') {
        !           211:         my (%okcourses,%courseinfo,%recent);
        !           212:         foreach my $domain (keys(%{$homecourses})) {
        !           213:             my $hashref = 
        !           214:                 &tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT());
        !           215:             if (ref($hashref) eq 'HASH') {
        !           216:                 while (my ($key,$value) = each(%$hashref)) {
        !           217:                     my $unesc_key = &unescape($key);
        !           218:                     if ($unesc_key =~ /^lasttime:(\w+)$/) {
        !           219:                         my $cid = $1;
        !           220:                         $cid =~ s/_/:/;
        !           221:                         if ($value > $yesterday ) {
        !           222:                             $recent{$cid} = 1;
        !           223:                         }
        !           224:                         next;
        !           225:                     }
        !           226:                     my $items = &Apache::lonnet::thaw_unescape($value);
        !           227:                     if (ref($items) eq 'HASH') {
        !           228:                         my ($cdom,$cnum) = split(/_/,$unesc_key);
        !           229:                         my $hashid = $cdom.':'.$cnum; 
        !           230:                         $courseinfo{$hashid} = $items;
        !           231:                         if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
        !           232:                             my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
        !           233:                             if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
        !           234:                                $okcourses{$hashid} = 1;
        !           235:                             }
        !           236:                         }
        !           237:                     }
        !           238:                 }
        !           239:                 unless (&untie_domain_hash($hashref)) {
        !           240:                     &logthis("Failed to untie tied hash for nohist_courseids.db for $domain");
        !           241:                 }
        !           242:             } else {
        !           243:                 &logthis("Failed to tie hash for nohist_courseids.db for $domain");
        !           244:             }
        !           245:         }
        !           246:         foreach my $hashid (keys(%recent)) {
        !           247:             my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
        !           248:             unless ($cached) {
        !           249:                 &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
        !           250:             }
        !           251:         }
        !           252:         foreach my $cdom (keys(%{$homecourses})) {
        !           253:             if (ref($homecourses->{$cdom}) eq 'HASH') {
        !           254:                 foreach my $cnum (keys(%{$homecourses->{$cdom}})) {
        !           255:                     my $hashid = $cdom.':'.$cnum;
        !           256:                     next if ($recent{$hashid});
        !           257:                     &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
        !           258:                 }
        !           259:             }
        !           260:         }
        !           261:         foreach my $hashid (keys(%okcourses)) {
        !           262:             my ($cdom,$cnum) = split(/:/,$hashid);
        !           263:             if ((ref($homecourses->{$cdom}) eq 'HASH') &&  
        !           264:                 (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) {
        !           265:                 foreach my $role (@{$homecourses->{$cdom}{$cnum}}) {
        !           266:                     if (ref($role) eq 'HASH') {
        !           267:                         while (my ($key,$value) = each(%{$role})) {
        !           268:                             if ($regexp eq '.') {
        !           269:                                 $count++;
        !           270:                                 if (defined($range) && $count >= $end)   { last; }
        !           271:                                 if (defined($range) && $count <  $start) { next; }
        !           272:                                 $result.=$key.'='.$value.'&';
        !           273:                             } else {
        !           274:                                 my $unescapeKey = &unescape($key);
        !           275:                                 if (eval('$unescapeKey=~/$regexp/')) {
        !           276:                                     $count++;
        !           277:                                     if (defined($range) && $count >= $end)   { last; }
        !           278:                                     if (defined($range) && $count <  $start) { next; }
        !           279:                                     $result.="$key=$value&";
        !           280:                                 }
        !           281:                             }
        !           282:                         }
        !           283:                     }
1.1       droeschl  284:                 }
                    285:             }
1.2     ! droeschl  286:         }
1.1       droeschl  287:     }
1.2     ! droeschl  288:     return $result;
        !           289: }
        !           290: 
1.1       droeschl  291: 
1.2     ! droeschl  292: sub useable_role {
        !           293:     my ($reqdmajor,$reqdminor,$major,$minor) = @_; 
        !           294:     if ($reqdmajor ne '' && $reqdminor ne '') {
        !           295:         return if (($major eq '' && $minor eq '') ||
        !           296:                    ($major < $reqdmajor) ||
        !           297:                    (($major == $reqdmajor) && ($minor < $reqdminor)));
        !           298:     }
1.1       droeschl  299:     return 1;
                    300: }
                    301: 
1.2     ! droeschl  302: 
        !           303: 
        !           304: 
        !           305: 
        !           306: 
1.1       droeschl  307: 1;
                    308: 
                    309: __END__
                    310: 
                    311: =head1 NAME
                    312: 
                    313: LONCAPA::Lond.pm
                    314: 
                    315: =head1 SYNOPSIS
                    316: 
                    317: #TODO
                    318: 
                    319: =head1 DESCRIPTION
                    320: 
                    321: #TODO
                    322: 
                    323: =head1 METHODS
                    324: 
                    325: =over 4
                    326: 
1.2     ! droeschl  327: =item dump_with_regexp( $tail, $client )
1.1       droeschl  328: 
                    329: Dump a profile database with an optional regular expression to match against
                    330: the keys.  In this dump, no effort is made to separate symb from version
                    331: information. Presumably the databases that are dumped by this command are of a
                    332: different structure.  Need to look at this and improve the documentation of
                    333: both this and the currentdump handler.
                    334: 
                    335: $tail a colon separated list containing
                    336: 
                    337: =over 
                    338: 
                    339: =item domain
                    340: 
                    341: =item user 
                    342: 
                    343: identifying the user.
                    344: 
                    345: =item namespace    
                    346: 
                    347: identifying the database.
                    348: 
                    349: =item regexp     
                    350: 
                    351: optional regular expression that is matched against database keywords to do
                    352: selective dumps.
                    353: 
                    354: =item range       
                    355: 
                    356: optional range of entries e.g., 10-20 would return the 10th to 19th items, etc.  
                    357: 
                    358: =back
                    359: 
                    360: $client is the channel open on the client.
                    361: 
                    362: Returns: 1 (Continue processing).
                    363: 
                    364: Side effects: response is written to $client.  
                    365: 
1.2     ! droeschl  366: 
        !           367: =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor, 
        !           368:         $homecourses, $ids )
        !           369: 
        !           370: releasereqd_check() will determine if a LON-CAPA version (defined in the
        !           371: $major,$minor args passed) is not too old to allow use of a role in a 
        !           372: course ($cnum,$cdom args passed), if at least one of the following applies: 
        !           373: (a) the course is a Community, (b) the course's home server is *not* the
        !           374: current server, or (c) cached course information is not stale. 
        !           375: 
        !           376: For the case where none of these apply, the course is added to the 
        !           377: $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
        !           378: The $homecourse hash ref is for courses for which the current server is the 
        !           379: home server.  LON-CAPA version requirements are checked elsewhere for the
        !           380: items in $homecourse.
        !           381: 
        !           382: 
        !           383: =item check_homecourses( $homecourses, $regexp, $count, $range, $start, $end, 
        !           384:         $major, $minor )
        !           385: 
        !           386: check_homecourses() will retrieve course information for those courses which
        !           387: are keys of the $homecourses hash ref (first arg). The nohist_courseids.db 
        !           388: GDBM file is tied and course information for each course retrieved. Last   
        !           389: visit (lasttime key) is also retrieved for each, and cached values updated  
        !           390: for any courses last visited less than 24 hours ago. Cached values are also
        !           391: updated for any courses included in the $homecourses hash ref.
        !           392: 
        !           393: The reason for the 24 hours constraint is that the cron entry in 
        !           394: /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes 
        !           395: cached course information to be updated nightly for courses with activity
        !           396: within the past 24 hours.
        !           397: 
        !           398: Role information for the user (included in a ref to an array of hashes as the
        !           399: value for each key in $homecourses) is appended to the result returned by the
        !           400: routine, which will in turn be appended to the string returned to the client
        !           401: hosting the user's session.
        !           402: 
        !           403: 
        !           404: =item useable_role( $reqdmajor, $reqdminor, $major, $minor )
        !           405: 
        !           406: useable_role() will compare the LON-CAPA version required by a course with 
        !           407: the version available on the client server.  If the client server's version
        !           408: is compatible, 1 will be returned.
        !           409: 
        !           410: 
1.1       droeschl  411: =back
                    412: 
                    413: =head1 BUGS
                    414: 
                    415: No known bugs at this time.
                    416: 
                    417: =head1 SEE ALSO
                    418: 
                    419: L<Apache::lonnet>, L<lond>
                    420: 
                    421: =cut  

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