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>
![[BACK]](/icons/back.gif){kind=icon}
Return to Lond.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom