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