1: # The LearningOnline Network
2: #
3: # $Id: Lond.pm,v 1.3 2012/04/26 20:00:57 droeschl Exp $
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 {
42: my ( $tail, $clientname, $clientversion ) = @_;
43: my ( $udom, $uname, $namespace, $regexp, $range ) =
44: split /:/, $tail;
45:
46: $regexp = defined $regexp ? unescape($regexp) : '.';
47:
48: my ($start,$end);
49:
50: if (defined($range)) {
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;
65: #
66: # When dump is for roles.db, determine if LON-CAPA version checking is needed.
67: # Sessions on 2.10 and later do not require version checking, as that occurs
68: # on the server hosting the user session, when constructing the roles/courses
69: # screen).
70: #
71: my $skipcheck;
72: my @ids = &Apache::lonnet::current_machine_ids();
73: my (%homecourses, $major, $minor, $now);
74: #
75: # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA
76: # version on the server which requested the data.
77: #
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;
85: }
86: $now = time;
87: }
88: while (my ($key,$value) = each(%$hashref)) {
89: if ($namespace eq 'roles' && (!$skipcheck)) {
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;
93: my ($role,$roleend,$rolestart) = split(/\_/,$value);
94: if (!$roleend || $roleend > $now) {
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: #
105: next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
106: $minor,\%homecourses,\@ids));
107: }
108: }
109: }
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";
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: #
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: }
284: }
285: }
286: }
287: }
288: return $result;
289: }
290:
291:
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: }
299: return 1;
300: }
301:
302:
303: sub get_courseinfo_hash {
304: my ($cnum,$cdom,$home) = @_;
305: my %info;
306: eval {
307: local($SIG{ALRM}) = sub { die "timeout\n"; };
308: local($SIG{__DIE__})='DEFAULT';
309: alarm(3);
310: %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
311: alarm(0);
312: };
313: if ($@) {
314: if ($@ eq "timeout\n") {
315: &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
316: } else {
317: &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
318: }
319: } else {
320: if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
321: my $hashid = $cdom.':'.$cnum;
322: return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
323: }
324: }
325: return;
326: }
327:
328:
329:
330:
331: 1;
332:
333: __END__
334:
335: =head1 NAME
336:
337: LONCAPA::Lond.pm
338:
339: =head1 SYNOPSIS
340:
341: #TODO
342:
343: =head1 DESCRIPTION
344:
345: #TODO
346:
347: =head1 METHODS
348:
349: =over 4
350:
351: =item dump_with_regexp( $tail, $client )
352:
353: Dump a profile database with an optional regular expression to match against
354: the keys. In this dump, no effort is made to separate symb from version
355: information. Presumably the databases that are dumped by this command are of a
356: different structure. Need to look at this and improve the documentation of
357: both this and the currentdump handler.
358:
359: $tail a colon separated list containing
360:
361: =over
362:
363: =item domain
364:
365: =item user
366:
367: identifying the user.
368:
369: =item namespace
370:
371: identifying the database.
372:
373: =item regexp
374:
375: optional regular expression that is matched against database keywords to do
376: selective dumps.
377:
378: =item range
379:
380: optional range of entries e.g., 10-20 would return the 10th to 19th items, etc.
381:
382: =back
383:
384: $client is the channel open on the client.
385:
386: Returns: 1 (Continue processing).
387:
388: Side effects: response is written to $client.
389:
390:
391: =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor,
392: $homecourses, $ids )
393:
394: releasereqd_check() will determine if a LON-CAPA version (defined in the
395: $major,$minor args passed) is not too old to allow use of a role in a
396: course ($cnum,$cdom args passed), if at least one of the following applies:
397: (a) the course is a Community, (b) the course's home server is *not* the
398: current server, or (c) cached course information is not stale.
399:
400: For the case where none of these apply, the course is added to the
401: $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
402: The $homecourse hash ref is for courses for which the current server is the
403: home server. LON-CAPA version requirements are checked elsewhere for the
404: items in $homecourse.
405:
406:
407: =item check_homecourses( $homecourses, $regexp, $count, $range, $start, $end,
408: $major, $minor )
409:
410: check_homecourses() will retrieve course information for those courses which
411: are keys of the $homecourses hash ref (first arg). The nohist_courseids.db
412: GDBM file is tied and course information for each course retrieved. Last
413: visit (lasttime key) is also retrieved for each, and cached values updated
414: for any courses last visited less than 24 hours ago. Cached values are also
415: updated for any courses included in the $homecourses hash ref.
416:
417: The reason for the 24 hours constraint is that the cron entry in
418: /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes
419: cached course information to be updated nightly for courses with activity
420: within the past 24 hours.
421:
422: Role information for the user (included in a ref to an array of hashes as the
423: value for each key in $homecourses) is appended to the result returned by the
424: routine, which will in turn be appended to the string returned to the client
425: hosting the user's session.
426:
427:
428: =item useable_role( $reqdmajor, $reqdminor, $major, $minor )
429:
430: useable_role() will compare the LON-CAPA version required by a course with
431: the version available on the client server. If the client server's version
432: is compatible, 1 will be returned.
433:
434:
435: =item get_courseinfo_hash( $cnum, $cdom, $home )
436:
437: get_courseinfo_hash() is used to retrieve course information from the db
438: file: nohist_courseids.db for a course for which the current server is *not*
439: the home server.
440:
441: A hash of a hash will be retrieved. The outer hash contains a single key --
442: courseID -- for the course for which the data are being requested.
443: The contents of the inner hash, for that single item in the outer hash
444: are returned (and cached in memcache for 10 minutes).
445:
446:
447:
448: =back
449:
450: =head1 BUGS
451:
452: No known bugs at this time.
453:
454: =head1 SEE ALSO
455:
456: L<Apache::lonnet>, L<lond>
457:
458: =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