Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.832
1.1 albertel 1: # The LearningOnline Network
2: # TCP networking package
1.12 www 3: #
1.832 ! raeburn 4: # $Id: lonnet.pm,v 1.831 2007/01/29 21:16:55 albertel Exp $
1.178 www 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.169 harris41 28: ###
29:
1.1 albertel 30: package Apache::lonnet;
31:
32: use strict;
1.8 www 33: use LWP::UserAgent();
1.15 www 34: use HTTP::Headers;
1.486 www 35: use HTTP::Date;
36: # use Date::Parse;
1.11 www 37: use vars
1.599 albertel 38: qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
39: %libserv %pr %prp $memcache %packagetab
1.662 raeburn 40: %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
1.741 raeburn 41: %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
1.599 albertel 42: %domaindescription %domain_auth_def %domain_auth_arg_def
1.685 raeburn 43: %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
44: $tmpdir $_64bit %env);
1.403 www 45:
1.1 albertel 46: use IO::Socket;
1.31 www 47: use GDBM_File;
1.208 albertel 48: use HTML::LCParser;
1.637 raeburn 49: use HTML::Parser;
1.88 www 50: use Fcntl qw(:flock);
1.557 albertel 51: use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
1.539 albertel 52: use Time::HiRes qw( gettimeofday tv_interval );
1.599 albertel 53: use Cache::Memcached;
1.676 albertel 54: use Digest::MD5;
1.790 albertel 55: use Math::Random;
1.807 albertel 56: use LONCAPA qw(:DEFAULT :match);
1.740 www 57: use LONCAPA::Configuration;
1.676 albertel 58:
1.195 www 59: my $readit;
1.550 foxr 60: my $max_connection_retries = 10; # Or some such value.
1.1 albertel 61:
1.619 albertel 62: require Exporter;
63:
64: our @ISA = qw (Exporter);
65: our @EXPORT = qw(%env);
66:
1.449 matthew 67: =pod
68:
69: =head1 Package Variables
70:
71: These are largely undocumented, so if you decipher one please note it here.
72:
73: =over 4
74:
75: =item $processmarker
76:
77: Contains the time this process was started and this servers host id.
78:
79: =item $dumpcount
80:
81: Counts the number of times a message log flush has been attempted (regardless
82: of success) by this process. Used as part of the filename when messages are
83: delayed.
84:
85: =back
86:
87: =cut
88:
89:
1.1 albertel 90: # --------------------------------------------------------------------- Logging
1.729 www 91: {
92: my $logid;
93: sub instructor_log {
94: my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
95: $logid++;
96: my $id=time().'00000'.$$.'00000'.$logid;
97: return &Apache::lonnet::put('nohist_'.$hash_name,
1.730 www 98: { $id => {
99: 'exe_uname' => $env{'user.name'},
100: 'exe_udom' => $env{'user.domain'},
101: 'exe_time' => time(),
102: 'exe_ip' => $ENV{'REMOTE_ADDR'},
103: 'delflag' => $delflag,
104: 'logentry' => $storehash,
105: 'uname' => $uname,
106: 'udom' => $udom,
107: }
108: },
1.729 www 109: $env{'course.'.$env{'request.course.id'}.'.domain'},
110: $env{'course.'.$env{'request.course.id'}.'.num'}
111: );
112: }
113: }
1.1 albertel 114:
1.163 harris41 115: sub logtouch {
116: my $execdir=$perlvar{'lonDaemons'};
1.448 albertel 117: unless (-e "$execdir/logs/lonnet.log") {
118: open(my $fh,">>$execdir/logs/lonnet.log");
1.163 harris41 119: close $fh;
120: }
121: my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
122: chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
123: }
124:
1.1 albertel 125: sub logthis {
126: my $message=shift;
127: my $execdir=$perlvar{'lonDaemons'};
128: my $now=time;
129: my $local=localtime($now);
1.448 albertel 130: if (open(my $fh,">>$execdir/logs/lonnet.log")) {
131: print $fh "$local ($$): $message\n";
132: close($fh);
133: }
1.1 albertel 134: return 1;
135: }
136:
137: sub logperm {
138: my $message=shift;
139: my $execdir=$perlvar{'lonDaemons'};
140: my $now=time;
141: my $local=localtime($now);
1.448 albertel 142: if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
143: print $fh "$now:$message:$local\n";
144: close($fh);
145: }
1.1 albertel 146: return 1;
147: }
148:
149: # -------------------------------------------------- Non-critical communication
150: sub subreply {
151: my ($cmd,$server)=@_;
1.704 albertel 152: my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
1.549 foxr 153: #
154: # With loncnew process trimming, there's a timing hole between lonc server
155: # process exit and the master server picking up the listen on the AF_UNIX
156: # socket. In that time interval, a lock file will exist:
157:
158: my $lockfile=$peerfile.".lock";
159: while (-e $lockfile) { # Need to wait for the lockfile to disappear.
160: sleep(1);
161: }
162: # At this point, either a loncnew parent is listening or an old lonc
1.550 foxr 163: # or loncnew child is listening so we can connect or everything's dead.
1.549 foxr 164: #
1.550 foxr 165: # We'll give the connection a few tries before abandoning it. If
166: # connection is not possible, we'll con_lost back to the client.
167: #
168: my $client;
169: for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
170: $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
171: Type => SOCK_STREAM,
172: Timeout => 10);
173: if($client) {
174: last; # Connected!
175: }
176: sleep(1); # Try again later if failed connection.
177: }
178: my $answer;
179: if ($client) {
1.704 albertel 180: print $client "sethost:$server:$cmd\n";
1.550 foxr 181: $answer=<$client>;
182: if (!$answer) { $answer="con_lost"; }
183: chomp($answer);
184: } else {
185: $answer = 'con_lost'; # Failed connection.
186: }
1.1 albertel 187: return $answer;
188: }
189:
190: sub reply {
191: my ($cmd,$server)=@_;
1.205 www 192: unless (defined($hostname{$server})) { return 'no_such_host'; }
1.1 albertel 193: my $answer=subreply($cmd,$server);
1.65 www 194: if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.672 albertel 195: &logthis("<font color=\"blue\">WARNING:".
1.12 www 196: " $cmd to $server returned $answer</font>");
197: }
1.1 albertel 198: return $answer;
199: }
200:
201: # ----------------------------------------------------------- Send USR1 to lonc
202:
203: sub reconlonc {
204: my $peerfile=shift;
205: &logthis("Trying to reconnect for $peerfile");
206: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
1.448 albertel 207: if (open(my $fh,"<$loncfile")) {
1.1 albertel 208: my $loncpid=<$fh>;
209: chomp($loncpid);
210: if (kill 0 => $loncpid) {
211: &logthis("lonc at pid $loncpid responding, sending USR1");
212: kill USR1 => $loncpid;
213: sleep 1;
214: if (-e "$peerfile") { return; }
215: &logthis("$peerfile still not there, give it another try");
216: sleep 5;
217: if (-e "$peerfile") { return; }
1.12 www 218: &logthis(
1.672 albertel 219: "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 220: } else {
1.12 www 221: &logthis(
1.672 albertel 222: "<font color=\"blue\">WARNING:".
1.12 www 223: " lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 224: }
225: } else {
1.672 albertel 226: &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
1.1 albertel 227: }
228: }
229:
230: # ------------------------------------------------------ Critical communication
1.12 www 231:
1.1 albertel 232: sub critical {
233: my ($cmd,$server)=@_;
1.89 www 234: unless ($hostname{$server}) {
1.672 albertel 235: &logthis("<font color=\"blue\">WARNING:".
1.89 www 236: " Critical message to unknown server ($server)</font>");
237: return 'no_such_host';
238: }
1.1 albertel 239: my $answer=reply($cmd,$server);
240: if ($answer eq 'con_lost') {
241: &reconlonc("$perlvar{'lonSockDir'}/$server");
1.589 albertel 242: my $answer=reply($cmd,$server);
1.1 albertel 243: if ($answer eq 'con_lost') {
244: my $now=time;
245: my $middlename=$cmd;
1.5 www 246: $middlename=substr($middlename,0,16);
1.1 albertel 247: $middlename=~s/\W//g;
248: my $dfilename=
1.305 www 249: "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
250: $dumpcount++;
1.1 albertel 251: {
1.448 albertel 252: my $dfh;
253: if (open($dfh,">$dfilename")) {
254: print $dfh "$cmd\n";
255: close($dfh);
256: }
1.1 albertel 257: }
258: sleep 2;
259: my $wcmd='';
260: {
1.448 albertel 261: my $dfh;
262: if (open($dfh,"<$dfilename")) {
263: $wcmd=<$dfh>;
264: close($dfh);
265: }
1.1 albertel 266: }
267: chomp($wcmd);
1.7 www 268: if ($wcmd eq $cmd) {
1.672 albertel 269: &logthis("<font color=\"blue\">WARNING: ".
1.12 www 270: "Connection buffer $dfilename: $cmd</font>");
1.1 albertel 271: &logperm("D:$server:$cmd");
272: return 'con_delayed';
273: } else {
1.672 albertel 274: &logthis("<font color=\"red\">CRITICAL:"
1.12 www 275: ." Critical connection failed: $server $cmd</font>");
1.1 albertel 276: &logperm("F:$server:$cmd");
277: return 'con_failed';
278: }
279: }
280: }
281: return $answer;
1.405 albertel 282: }
283:
1.755 albertel 284: # ------------------------------------------- check if return value is an error
285:
286: sub error {
287: my ($result) = @_;
1.756 albertel 288: if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
1.755 albertel 289: if ($2 == 2) { return undef; }
290: return $1;
291: }
292: return undef;
293: }
294:
1.783 albertel 295: sub convert_and_load_session_env {
296: my ($lonidsdir,$handle)=@_;
297: my @profile;
298: {
299: open(my $idf,"$lonidsdir/$handle.id");
300: flock($idf,LOCK_SH);
301: @profile=<$idf>;
302: close($idf);
303: }
304: my %temp_env;
305: foreach my $line (@profile) {
1.786 albertel 306: if ($line !~ m/=/) {
307: return 0;
308: }
1.783 albertel 309: chomp($line);
310: my ($envname,$envvalue)=split(/=/,$line,2);
311: $temp_env{&unescape($envname)} = &unescape($envvalue);
312: }
313: unlink("$lonidsdir/$handle.id");
314: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
315: 0640)) {
316: %disk_env = %temp_env;
317: @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
318: untie(%disk_env);
319: }
1.786 albertel 320: return 1;
1.783 albertel 321: }
322:
1.374 www 323: # ------------------------------------------- Transfer profile into environment
1.780 albertel 324: my $env_loaded;
325: sub transfer_profile_to_env {
1.788 albertel 326: my ($lonidsdir,$handle,$force_transfer) = @_;
327: if (!$force_transfer && $env_loaded) { return; }
1.374 www 328:
1.720 albertel 329: if (!defined($lonidsdir)) {
330: $lonidsdir = $perlvar{'lonIDsDir'};
331: }
332: if (!defined($handle)) {
333: ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
334: }
335:
1.786 albertel 336: my $convert;
337: {
338: open(my $idf,"$lonidsdir/$handle.id");
339: flock($idf,LOCK_SH);
340: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
341: &GDBM_READER(),0640)) {
342: @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
343: untie(%disk_env);
344: } else {
345: $convert = 1;
346: }
347: }
348: if ($convert) {
349: if (!&convert_and_load_session_env($lonidsdir,$handle)) {
350: &logthis("Failed to load session, or convert session.");
351: }
1.374 www 352: }
1.783 albertel 353:
1.786 albertel 354: my %remove;
1.783 albertel 355: while ( my $envname = each(%env) ) {
1.433 matthew 356: if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
357: if ($time < time-300) {
1.783 albertel 358: $remove{$key}++;
1.433 matthew 359: }
360: }
361: }
1.783 albertel 362:
1.619 albertel 363: $env{'user.environment'} = "$lonidsdir/$handle.id";
1.780 albertel 364: $env_loaded=1;
1.783 albertel 365: foreach my $expired_key (keys(%remove)) {
1.433 matthew 366: &delenv($expired_key);
1.374 www 367: }
1.1 albertel 368: }
369:
1.830 albertel 370: sub timed_flock {
371: my ($file,$lock_type) = @_;
372: my $failed=0;
373: eval {
374: local $SIG{__DIE__}='DEFAULT';
375: local $SIG{ALRM}=sub {
376: $failed=1;
377: die("failed lock");
378: };
379: alarm(13);
380: flock($file,$lock_type);
381: alarm(0);
382: };
383: if ($failed) {
384: return undef;
385: } else {
386: return 1;
387: }
388: }
389:
1.5 www 390: # ---------------------------------------------------------- Append Environment
391:
392: sub appenv {
1.6 www 393: my %newenv=@_;
1.692 albertel 394: foreach my $key (keys(%newenv)) {
395: if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
1.672 albertel 396: &logthis("<font color=\"blue\">WARNING: ".
1.692 albertel 397: "Attempt to modify environment ".$key." to ".$newenv{$key}
1.151 www 398: .'</font>');
1.692 albertel 399: delete($newenv{$key});
1.35 www 400: } else {
1.692 albertel 401: $env{$key}=$newenv{$key};
1.35 www 402: }
1.191 harris41 403: }
1.830 albertel 404: open(my $env_file,$env{'user.environment'});
405: if (&timed_flock($env_file,LOCK_EX)
406: &&
407: tie(my %disk_env,'GDBM_File',$env{'user.environment'},
408: (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
1.783 albertel 409: while (my ($key,$value) = each(%newenv)) {
410: $disk_env{$key} = $value;
1.448 albertel 411: }
1.783 albertel 412: untie(%disk_env);
1.56 www 413: }
414: return 'ok';
415: }
416: # ----------------------------------------------------- Delete from Environment
417:
418: sub delenv {
419: my $delthis=shift;
420: if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
1.672 albertel 421: &logthis("<font color=\"blue\">WARNING: ".
1.56 www 422: "Attempt to delete from environment ".$delthis);
423: return 'error';
424: }
1.830 albertel 425: open(my $env_file,$env{'user.environment'});
426: if (&timed_flock($env_file,LOCK_EX)
427: &&
428: tie(my %disk_env,'GDBM_File',$env{'user.environment'},
429: (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
1.783 albertel 430: foreach my $key (keys(%disk_env)) {
431: if ($key=~/^$delthis/) {
1.619 albertel 432: delete($env{$key});
1.783 albertel 433: delete($disk_env{$key});
1.473 matthew 434: }
1.448 albertel 435: }
1.783 albertel 436: untie(%disk_env);
1.5 www 437: }
438: return 'ok';
1.369 albertel 439: }
440:
1.790 albertel 441: sub get_env_multiple {
442: my ($name) = @_;
443: my @values;
444: if (defined($env{$name})) {
445: # exists is it an array
446: if (ref($env{$name})) {
447: @values=@{ $env{$name} };
448: } else {
449: $values[0]=$env{$name};
450: }
451: }
452: return(@values);
453: }
454:
1.369 albertel 455: # ------------------------------------------ Find out current server userload
456: # there is a copy in lond
457: sub userload {
458: my $numusers=0;
459: {
460: opendir(LONIDS,$perlvar{'lonIDsDir'});
461: my $filename;
462: my $curtime=time;
463: while ($filename=readdir(LONIDS)) {
464: if ($filename eq '.' || $filename eq '..') {next;}
1.404 albertel 465: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
1.437 albertel 466: if ($curtime-$mtime < 1800) { $numusers++; }
1.369 albertel 467: }
468: closedir(LONIDS);
469: }
470: my $userloadpercent=0;
471: my $maxuserload=$perlvar{'lonUserLoadLim'};
472: if ($maxuserload) {
1.371 albertel 473: $userloadpercent=100*$numusers/$maxuserload;
1.369 albertel 474: }
1.372 albertel 475: $userloadpercent=sprintf("%.2f",$userloadpercent);
1.369 albertel 476: return $userloadpercent;
1.283 www 477: }
478:
479: # ------------------------------------------ Fight off request when overloaded
480:
481: sub overloaderror {
482: my ($r,$checkserver)=@_;
483: unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
484: my $loadavg;
485: if ($checkserver eq $perlvar{'lonHostID'}) {
1.448 albertel 486: open(my $loadfile,'/proc/loadavg');
1.283 www 487: $loadavg=<$loadfile>;
488: $loadavg =~ s/\s.*//g;
1.285 matthew 489: $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
1.448 albertel 490: close($loadfile);
1.283 www 491: } else {
492: $loadavg=&reply('load',$checkserver);
493: }
1.285 matthew 494: my $overload=$loadavg-100;
1.283 www 495: if ($overload>0) {
1.285 matthew 496: $r->err_headers_out->{'Retry-After'}=$overload;
1.283 www 497: $r->log_error('Overload of '.$overload.' on '.$checkserver);
1.554 www 498: return 413;
1.283 www 499: }
500: return '';
1.5 www 501: }
1.1 albertel 502:
503: # ------------------------------ Find server with least workload from spare.tab
1.11 www 504:
1.1 albertel 505: sub spareserver {
1.670 albertel 506: my ($loadpercent,$userloadpercent,$want_server_name) = @_;
1.784 albertel 507: my $spare_server;
1.370 albertel 508: if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
1.784 albertel 509: my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
510: : $userloadpercent;
511:
512: foreach my $try_server (@{ $spareid{'primary'} }) {
513: ($spare_server, $lowest_load) =
514: &compare_server_load($try_server, $spare_server, $lowest_load);
515: }
516:
517: my $found_server = ($spare_server ne '' && $lowest_load < 100);
518:
519: if (!$found_server) {
520: foreach my $try_server (@{ $spareid{'default'} }) {
521: ($spare_server, $lowest_load) =
522: &compare_server_load($try_server, $spare_server, $lowest_load);
523: }
524: }
525:
526: if (!$want_server_name) {
527: $spare_server="http://$hostname{$spare_server}";
528: }
529: return $spare_server;
530: }
531:
532: sub compare_server_load {
533: my ($try_server, $spare_server, $lowest_load) = @_;
534:
535: my $loadans = &reply('load', $try_server);
536: my $userloadans = &reply('userload',$try_server);
537:
538: if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
539: next; #didn't get a number from the server
540: }
541:
542: my $load;
543: if ($loadans =~ /\d/) {
544: if ($userloadans =~ /\d/) {
545: #both are numbers, pick the bigger one
546: $load = ($loadans > $userloadans) ? $loadans
547: : $userloadans;
1.411 albertel 548: } else {
1.784 albertel 549: $load = $loadans;
1.411 albertel 550: }
1.784 albertel 551: } else {
552: $load = $userloadans;
553: }
554:
555: if (($load =~ /\d/) && ($load < $lowest_load)) {
556: $spare_server = $try_server;
557: $lowest_load = $load;
1.370 albertel 558: }
1.784 albertel 559: return ($spare_server,$lowest_load);
1.202 matthew 560: }
561: # --------------------------------------------- Try to change a user's password
562:
563: sub changepass {
1.799 raeburn 564: my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
1.202 matthew 565: $currentpass = &escape($currentpass);
566: $newpass = &escape($newpass);
1.799 raeburn 567: my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
1.202 matthew 568: $server);
569: if (! $answer) {
570: &logthis("No reply on password change request to $server ".
571: "by $uname in domain $udom.");
572: } elsif ($answer =~ "^ok") {
573: &logthis("$uname in $udom successfully changed their password ".
574: "on $server.");
575: } elsif ($answer =~ "^pwchange_failure") {
576: &logthis("$uname in $udom was unable to change their password ".
577: "on $server. The action was blocked by either lcpasswd ".
578: "or pwchange");
579: } elsif ($answer =~ "^non_authorized") {
580: &logthis("$uname in $udom did not get their password correct when ".
581: "attempting to change it on $server.");
582: } elsif ($answer =~ "^auth_mode_error") {
583: &logthis("$uname in $udom attempted to change their password despite ".
584: "not being locally or internally authenticated on $server.");
585: } elsif ($answer =~ "^unknown_user") {
586: &logthis("$uname in $udom attempted to change their password ".
587: "on $server but were unable to because $server is not ".
588: "their home server.");
589: } elsif ($answer =~ "^refused") {
590: &logthis("$server refused to change $uname in $udom password because ".
591: "it was sent an unencrypted request to change the password.");
592: }
593: return $answer;
1.1 albertel 594: }
595:
1.169 harris41 596: # ----------------------- Try to determine user's current authentication scheme
597:
598: sub queryauthenticate {
599: my ($uname,$udom)=@_;
1.456 albertel 600: my $uhome=&homeserver($uname,$udom);
601: if (!$uhome) {
602: &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
603: return 'no_host';
604: }
605: my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
606: if ($answer =~ /^(unknown_user|refused|con_lost)/) {
607: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
1.169 harris41 608: }
1.456 albertel 609: return $answer;
1.169 harris41 610: }
611:
1.1 albertel 612: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11 www 613:
1.1 albertel 614: sub authenticate {
615: my ($uname,$upass,$udom)=@_;
1.807 albertel 616: $upass=&escape($upass);
617: $uname= &LONCAPA::clean_username($uname);
1.471 albertel 618: my $uhome=&homeserver($uname,$udom);
619: if (!$uhome) {
620: &logthis("User $uname at $udom is unknown in authenticate");
621: return 'no_host';
1.1 albertel 622: }
1.471 albertel 623: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
624: if ($answer eq 'authorized') {
625: &logthis("User $uname at $udom authorized by $uhome");
626: return $uhome;
627: }
628: if ($answer eq 'non_authorized') {
629: &logthis("User $uname at $udom rejected by $uhome");
630: return 'no_host';
1.9 www 631: }
1.471 albertel 632: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
1.1 albertel 633: return 'no_host';
634: }
635:
636: # ---------------------- Find the homebase for a user from domain's lib servers
1.11 www 637:
1.599 albertel 638: my %homecache;
1.1 albertel 639: sub homeserver {
1.230 stredwic 640: my ($uname,$udom,$ignoreBadCache)=@_;
1.1 albertel 641: my $index="$uname:$udom";
1.426 albertel 642:
1.599 albertel 643: if (exists($homecache{$index})) { return $homecache{$index}; }
1.1 albertel 644: my $tryserver;
645: foreach $tryserver (keys %libserv) {
1.230 stredwic 646: next if ($ignoreBadCache ne 'true' &&
1.231 stredwic 647: exists($badServerCache{$tryserver}));
1.1 albertel 648: if ($hostdom{$tryserver} eq $udom) {
649: my $answer=reply("home:$udom:$uname",$tryserver);
650: if ($answer eq 'found') {
1.599 albertel 651: return $homecache{$index}=$tryserver;
1.231 stredwic 652: } elsif ($answer eq 'no_host') {
653: $badServerCache{$tryserver}=1;
1.221 matthew 654: }
1.1 albertel 655: }
656: }
657: return 'no_host';
1.70 www 658: }
659:
660: # ------------------------------------- Find the usernames behind a list of IDs
661:
662: sub idget {
663: my ($udom,@ids)=@_;
664: my %returnhash=();
665:
666: my $tryserver;
667: foreach $tryserver (keys %libserv) {
668: if ($hostdom{$tryserver} eq $udom) {
669: my $idlist=join('&',@ids);
670: $idlist=~tr/A-Z/a-z/;
671: my $reply=&reply("idget:$udom:".$idlist,$tryserver);
672: my @answer=();
1.76 www 673: if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
1.70 www 674: @answer=split(/\&/,$reply);
675: } ;
676: my $i;
677: for ($i=0;$i<=$#ids;$i++) {
678: if ($answer[$i]) {
679: $returnhash{$ids[$i]}=$answer[$i];
680: }
681: }
682: }
683: }
684: return %returnhash;
685: }
686:
687: # ------------------------------------- Find the IDs behind a list of usernames
688:
689: sub idrget {
690: my ($udom,@unames)=@_;
691: my %returnhash=();
1.800 albertel 692: foreach my $uname (@unames) {
693: $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
1.191 harris41 694: }
1.70 www 695: return %returnhash;
696: }
697:
698: # ------------------------------- Store away a list of names and associated IDs
699:
700: sub idput {
701: my ($udom,%ids)=@_;
702: my %servers=();
1.800 albertel 703: foreach my $uname (keys(%ids)) {
704: &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
705: my $uhom=&homeserver($uname,$udom);
1.70 www 706: if ($uhom ne 'no_host') {
1.800 albertel 707: my $id=&escape($ids{$uname});
1.70 www 708: $id=~tr/A-Z/a-z/;
1.800 albertel 709: my $esc_unam=&escape($uname);
1.70 www 710: if ($servers{$uhom}) {
1.800 albertel 711: $servers{$uhom}.='&'.$id.'='.$esc_unam;
1.70 www 712: } else {
1.800 albertel 713: $servers{$uhom}=$id.'='.$esc_unam;
1.70 www 714: }
715: }
1.191 harris41 716: }
1.800 albertel 717: foreach my $server (keys(%servers)) {
718: &critical('idput:'.$udom.':'.$servers{$server},$server);
1.191 harris41 719: }
1.344 www 720: }
721:
1.806 raeburn 722: # ------------------------------------------- get items from domain db files
723:
724: sub get_dom {
725: my ($namespace,$storearr,$udom)=@_;
726: my $items='';
727: foreach my $item (@$storearr) {
728: $items.=&escape($item).'&';
729: }
730: $items=~s/\&$//;
731: if (!$udom) { $udom=$env{'user.domain'}; }
732: if (exists($domain_primary{$udom})) {
733: my $uhome=$domain_primary{$udom};
734: my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
735: my @pairs=split(/\&/,$rep);
736: if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
737: return @pairs;
738: }
739: my %returnhash=();
740: my $i=0;
741: foreach my $item (@$storearr) {
742: $returnhash{$item}=&thaw_unescape($pairs[$i]);
743: $i++;
744: }
745: return %returnhash;
746: } else {
747: &logthis("get_dom failed - no primary domain server for $udom");
748: }
749: }
750:
751: # -------------------------------------------- put items in domain db files
752:
753: sub put_dom {
754: my ($namespace,$storehash,$udom)=@_;
755: if (!$udom) { $udom=$env{'user.domain'}; }
756: if (exists($domain_primary{$udom})) {
757: my $uhome=$domain_primary{$udom};
758: my $items='';
759: foreach my $item (keys(%$storehash)) {
760: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
761: }
762: $items=~s/\&$//;
763: return &reply("putdom:$udom:$namespace:$items",$uhome);
764: } else {
765: &logthis("put_dom failed - no primary domain server for $udom");
766: }
767: }
768:
1.344 www 769: # --------------------------------------------------- Assign a key to a student
770:
771: sub assign_access_key {
1.364 www 772: #
773: # a valid key looks like uname:udom#comments
774: # comments are being appended
775: #
1.498 www 776: my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
777: $kdom=
1.620 albertel 778: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom));
1.498 www 779: $knum=
1.620 albertel 780: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum));
1.344 www 781: $cdom=
1.620 albertel 782: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344 www 783: $cnum=
1.620 albertel 784: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
785: $udom=$env{'user.name'} unless (defined($udom));
786: $uname=$env{'user.domain'} unless (defined($uname));
1.498 www 787: my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
1.364 www 788: if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
1.479 albertel 789: ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {
1.364 www 790: # assigned to this person
791: # - this should not happen,
1.345 www 792: # unless something went wrong
793: # the first time around
794: # ready to assign
1.364 www 795: $logentry=$1.'; '.$logentry;
1.496 www 796: if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
1.498 www 797: $kdom,$knum) eq 'ok') {
1.345 www 798: # key now belongs to user
1.346 www 799: my $envkey='key.'.$cdom.'_'.$cnum;
1.345 www 800: if (&put('environment',{$envkey => $ckey}) eq 'ok') {
801: &appenv('environment.'.$envkey => $ckey);
802: return 'ok';
803: } else {
804: return
805: 'error: Count not permanently assign key, will need to be re-entered later.';
806: }
807: } else {
808: return 'error: Could not assign key, try again later.';
809: }
1.364 www 810: } elsif (!$existing{$ckey}) {
1.345 www 811: # the key does not exist
812: return 'error: The key does not exist';
813: } else {
814: # the key is somebody else's
815: return 'error: The key is already in use';
816: }
1.344 www 817: }
818:
1.364 www 819: # ------------------------------------------ put an additional comment on a key
820:
821: sub comment_access_key {
822: #
823: # a valid key looks like uname:udom#comments
824: # comments are being appended
825: #
826: my ($ckey,$cdom,$cnum,$logentry)=@_;
827: $cdom=
1.620 albertel 828: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.364 www 829: $cnum=
1.620 albertel 830: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
1.364 www 831: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
832: if ($existing{$ckey}) {
833: $existing{$ckey}.='; '.$logentry;
834: # ready to assign
1.367 www 835: if (&put('accesskeys',{$ckey=>$existing{$ckey}},
1.364 www 836: $cdom,$cnum) eq 'ok') {
837: return 'ok';
838: } else {
839: return 'error: Count not store comment.';
840: }
841: } else {
842: # the key does not exist
843: return 'error: The key does not exist';
844: }
845: }
846:
1.344 www 847: # ------------------------------------------------------ Generate a set of keys
848:
849: sub generate_access_keys {
1.364 www 850: my ($number,$cdom,$cnum,$logentry)=@_;
1.344 www 851: $cdom=
1.620 albertel 852: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344 www 853: $cnum=
1.620 albertel 854: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
1.361 www 855: unless (&allowed('mky',$cdom)) { return 0; }
1.344 www 856: unless (($cdom) && ($cnum)) { return 0; }
857: if ($number>10000) { return 0; }
858: sleep(2); # make sure don't get same seed twice
859: srand(time()^($$+($$<<15))); # from "Programming Perl"
860: my $total=0;
861: for (my $i=1;$i<=$number;$i++) {
862: my $newkey=sprintf("%lx",int(100000*rand)).'-'.
863: sprintf("%lx",int(100000*rand)).'-'.
864: sprintf("%lx",int(100000*rand));
865: $newkey=~s/1/g/g; # folks mix up 1 and l
866: $newkey=~s/0/h/g; # and also 0 and O
867: my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
868: if ($existing{$newkey}) {
869: $i--;
870: } else {
1.364 www 871: if (&put('accesskeys',
872: { $newkey => '# generated '.localtime().
1.620 albertel 873: ' by '.$env{'user.name'}.'@'.$env{'user.domain'}.
1.364 www 874: '; '.$logentry },
875: $cdom,$cnum) eq 'ok') {
1.344 www 876: $total++;
877: }
878: }
879: }
1.620 albertel 880: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
1.344 www 881: 'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
882: return $total;
883: }
884:
885: # ------------------------------------------------------- Validate an accesskey
886:
887: sub validate_access_key {
888: my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
889: $cdom=
1.620 albertel 890: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344 www 891: $cnum=
1.620 albertel 892: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
893: $udom=$env{'user.domain'} unless (defined($udom));
894: $uname=$env{'user.name'} unless (defined($uname));
1.345 www 895: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
1.479 albertel 896: return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
1.70 www 897: }
898:
899: # ------------------------------------- Find the section of student in a course
1.652 albertel 900: sub devalidate_getsection_cache {
901: my ($udom,$unam,$courseid)=@_;
902: my $hashid="$udom:$unam:$courseid";
903: &devalidate_cache_new('getsection',$hashid);
904: }
1.298 matthew 905:
1.815 albertel 906: sub courseid_to_courseurl {
907: my ($courseid) = @_;
908: #already url style courseid
909: return $courseid if ($courseid =~ m{^/});
910:
911: if (exists($env{'course.'.$courseid.'.num'})) {
912: my $cnum = $env{'course.'.$courseid.'.num'};
913: my $cdom = $env{'course.'.$courseid.'.domain'};
914: return "/$cdom/$cnum";
915: }
916:
917: my %courseinfo=&Apache::lonnet::coursedescription($courseid);
918: if (exists($courseinfo{'num'})) {
919: return "/$courseinfo{'domain'}/$courseinfo{'num'}";
920: }
921:
922: return undef;
923: }
924:
1.298 matthew 925: sub getsection {
926: my ($udom,$unam,$courseid)=@_;
1.599 albertel 927: my $cachetime=1800;
1.551 albertel 928:
929: my $hashid="$udom:$unam:$courseid";
1.599 albertel 930: my ($result,$cached)=&is_cached_new('getsection',$hashid);
1.551 albertel 931: if (defined($cached)) { return $result; }
932:
1.298 matthew 933: my %Pending;
934: my %Expired;
935: #
936: # Each role can either have not started yet (pending), be active,
937: # or have expired.
938: #
939: # If there is an active role, we are done.
940: #
941: # If there is more than one role which has not started yet,
942: # choose the one which will start sooner
943: # If there is one role which has not started yet, return it.
944: #
945: # If there is more than one expired role, choose the one which ended last.
946: # If there is a role which has expired, return it.
947: #
1.815 albertel 948: $courseid = &courseid_to_courseurl($courseid);
1.817 raeburn 949: my %roleshash = &dump('roles',$udom,$unam,$courseid);
950: foreach my $key (keys(%roleshash)) {
1.479 albertel 951: next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
1.298 matthew 952: my $section=$1;
953: if ($key eq $courseid.'_st') { $section=''; }
1.817 raeburn 954: my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
1.298 matthew 955: my $now=time;
1.548 albertel 956: if (defined($end) && $end && ($now > $end)) {
1.298 matthew 957: $Expired{$end}=$section;
958: next;
959: }
1.548 albertel 960: if (defined($start) && $start && ($now < $start)) {
1.298 matthew 961: $Pending{$start}=$section;
962: next;
963: }
1.599 albertel 964: return &do_cache_new('getsection',$hashid,$section,$cachetime);
1.298 matthew 965: }
966: #
967: # Presumedly there will be few matching roles from the above
968: # loop and the sorting time will be negligible.
969: if (scalar(keys(%Pending))) {
970: my ($time) = sort {$a <=> $b} keys(%Pending);
1.599 albertel 971: return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
1.298 matthew 972: }
973: if (scalar(keys(%Expired))) {
974: my @sorted = sort {$a <=> $b} keys(%Expired);
975: my $time = pop(@sorted);
1.599 albertel 976: return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
1.298 matthew 977: }
1.599 albertel 978: return &do_cache_new('getsection',$hashid,'-1',$cachetime);
1.298 matthew 979: }
1.70 www 980:
1.599 albertel 981: sub save_cache {
982: &purge_remembered();
1.722 albertel 983: #&Apache::loncommon::validate_page();
1.620 albertel 984: undef(%env);
1.780 albertel 985: undef($env_loaded);
1.599 albertel 986: }
1.452 albertel 987:
1.599 albertel 988: my $to_remember=-1;
989: my %remembered;
990: my %accessed;
991: my $kicks=0;
992: my $hits=0;
993: sub devalidate_cache_new {
994: my ($name,$id,$debug) = @_;
995: if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
996: $id=&escape($name.':'.$id);
997: $memcache->delete($id);
998: delete($remembered{$id});
999: delete($accessed{$id});
1000: }
1001:
1002: sub is_cached_new {
1003: my ($name,$id,$debug) = @_;
1004: $id=&escape($name.':'.$id);
1005: if (exists($remembered{$id})) {
1006: if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
1007: $accessed{$id}=[&gettimeofday()];
1008: $hits++;
1009: return ($remembered{$id},1);
1010: }
1011: my $value = $memcache->get($id);
1012: if (!(defined($value))) {
1013: if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
1.417 albertel 1014: return (undef,undef);
1.416 albertel 1015: }
1.599 albertel 1016: if ($value eq '__undef__') {
1017: if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
1018: $value=undef;
1019: }
1020: &make_room($id,$value,$debug);
1021: if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
1022: return ($value,1);
1023: }
1024:
1025: sub do_cache_new {
1026: my ($name,$id,$value,$time,$debug) = @_;
1027: $id=&escape($name.':'.$id);
1028: my $setvalue=$value;
1029: if (!defined($setvalue)) {
1030: $setvalue='__undef__';
1031: }
1.623 albertel 1032: if (!defined($time) ) {
1033: $time=600;
1034: }
1.599 albertel 1035: if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
1.600 albertel 1036: $memcache->set($id,$setvalue,$time);
1037: # need to make a copy of $value
1038: #&make_room($id,$value,$debug);
1.599 albertel 1039: return $value;
1040: }
1041:
1042: sub make_room {
1043: my ($id,$value,$debug)=@_;
1044: $remembered{$id}=$value;
1045: if ($to_remember<0) { return; }
1046: $accessed{$id}=[&gettimeofday()];
1047: if (scalar(keys(%remembered)) <= $to_remember) { return; }
1048: my $to_kick;
1049: my $max_time=0;
1050: foreach my $other (keys(%accessed)) {
1051: if (&tv_interval($accessed{$other}) > $max_time) {
1052: $to_kick=$other;
1053: $max_time=&tv_interval($accessed{$other});
1054: }
1055: }
1056: delete($remembered{$to_kick});
1057: delete($accessed{$to_kick});
1058: $kicks++;
1059: if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
1.541 albertel 1060: return;
1061: }
1062:
1.599 albertel 1063: sub purge_remembered {
1.604 albertel 1064: #&logthis("Tossing ".scalar(keys(%remembered)));
1065: #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
1.599 albertel 1066: undef(%remembered);
1067: undef(%accessed);
1.428 albertel 1068: }
1.70 www 1069: # ------------------------------------- Read an entry from a user's environment
1070:
1071: sub userenvironment {
1072: my ($udom,$unam,@what)=@_;
1073: my %returnhash=();
1074: my @answer=split(/\&/,
1075: &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
1076: &homeserver($unam,$udom)));
1077: my $i;
1078: for ($i=0;$i<=$#what;$i++) {
1079: $returnhash{$what[$i]}=&unescape($answer[$i]);
1080: }
1081: return %returnhash;
1.1 albertel 1082: }
1083:
1.617 albertel 1084: # ---------------------------------------------------------- Get a studentphoto
1085: sub studentphoto {
1086: my ($udom,$unam,$ext) = @_;
1087: my $home=&Apache::lonnet::homeserver($unam,$udom);
1.706 raeburn 1088: if (defined($env{'request.course.id'})) {
1.708 raeburn 1089: if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
1.706 raeburn 1090: if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
1091: return(&retrievestudentphoto($udom,$unam,$ext));
1092: } else {
1093: my ($result,$perm_reqd)=
1.707 albertel 1094: &Apache::lonnet::auto_photo_permission($unam,$udom);
1.706 raeburn 1095: if ($result eq 'ok') {
1096: if (!($perm_reqd eq 'yes')) {
1097: return(&retrievestudentphoto($udom,$unam,$ext));
1098: }
1099: }
1100: }
1101: }
1102: } else {
1103: my ($result,$perm_reqd) =
1.707 albertel 1104: &Apache::lonnet::auto_photo_permission($unam,$udom);
1.706 raeburn 1105: if ($result eq 'ok') {
1106: if (!($perm_reqd eq 'yes')) {
1107: return(&retrievestudentphoto($udom,$unam,$ext));
1108: }
1109: }
1110: }
1111: return '/adm/lonKaputt/lonlogo_broken.gif';
1112: }
1113:
1114: sub retrievestudentphoto {
1115: my ($udom,$unam,$ext,$type) = @_;
1116: my $home=&Apache::lonnet::homeserver($unam,$udom);
1117: my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
1118: if ($ret eq 'ok') {
1119: my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
1120: if ($type eq 'thumbnail') {
1121: $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
1122: }
1123: my $tokenurl=&Apache::lonnet::tokenwrapper($url);
1124: return $tokenurl;
1125: } else {
1126: if ($type eq 'thumbnail') {
1127: return '/adm/lonKaputt/genericstudent_tn.gif';
1128: } else {
1129: return '/adm/lonKaputt/lonlogo_broken.gif';
1130: }
1.617 albertel 1131: }
1132: }
1133:
1.263 www 1134: # -------------------------------------------------------------------- New chat
1135:
1136: sub chatsend {
1.724 raeburn 1137: my ($newentry,$anon,$group)=@_;
1.620 albertel 1138: my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
1139: my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1140: my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
1.263 www 1141: &reply('chatsend:'.$cdom.':'.$cnum.':'.
1.620 albertel 1142: &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
1.724 raeburn 1143: &escape($newentry)).':'.$group,$chome);
1.292 www 1144: }
1145:
1146: # ------------------------------------------ Find current version of a resource
1147:
1148: sub getversion {
1149: my $fname=&clutter(shift);
1150: unless ($fname=~/^\/res\//) { return -1; }
1151: return ¤tversion(&filelocation('',$fname));
1152: }
1153:
1154: sub currentversion {
1155: my $fname=shift;
1.599 albertel 1156: my ($result,$cached)=&is_cached_new('resversion',$fname);
1.440 www 1157: if (defined($cached)) { return $result; }
1.292 www 1158: my $author=$fname;
1159: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1160: my ($udom,$uname)=split(/\//,$author);
1161: my $home=homeserver($uname,$udom);
1162: if ($home eq 'no_host') {
1163: return -1;
1164: }
1165: my $answer=reply("currentversion:$fname",$home);
1166: if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
1167: return -1;
1168: }
1.599 albertel 1169: return &do_cache_new('resversion',$fname,$answer,600);
1.263 www 1170: }
1171:
1.1 albertel 1172: # ----------------------------- Subscribe to a resource, return URL if possible
1.11 www 1173:
1.1 albertel 1174: sub subscribe {
1175: my $fname=shift;
1.761 raeburn 1176: if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
1.532 albertel 1177: $fname=~s/[\n\r]//g;
1.1 albertel 1178: my $author=$fname;
1179: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1180: my ($udom,$uname)=split(/\//,$author);
1181: my $home=homeserver($uname,$udom);
1.335 albertel 1182: if ($home eq 'no_host') {
1183: return 'not_found';
1.1 albertel 1184: }
1185: my $answer=reply("sub:$fname",$home);
1.64 www 1186: if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
1187: $answer.=' by '.$home;
1188: }
1.1 albertel 1189: return $answer;
1190: }
1191:
1.8 www 1192: # -------------------------------------------------------------- Replicate file
1193:
1194: sub repcopy {
1195: my $filename=shift;
1.23 www 1196: $filename=~s/\/+/\//g;
1.607 raeburn 1197: if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }
1198: if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
1.538 albertel 1199: if ($filename=~m|^/home/httpd/html/userfiles/| or
1.609 banghart 1200: $filename=~m -^/*(uploaded|editupload)/-) {
1.538 albertel 1201: return &repcopy_userfile($filename);
1202: }
1.532 albertel 1203: $filename=~s/[\n\r]//g;
1.8 www 1204: my $transname="$filename.in.transfer";
1.828 www 1205: # FIXME: this should flock
1.607 raeburn 1206: if ((-e $filename) || (-e $transname)) { return 'ok'; }
1.8 www 1207: my $remoteurl=subscribe($filename);
1.64 www 1208: if ($remoteurl =~ /^con_lost by/) {
1209: &logthis("Subscribe returned $remoteurl: $filename");
1.607 raeburn 1210: return 'unavailable';
1.8 www 1211: } elsif ($remoteurl eq 'not_found') {
1.441 albertel 1212: #&logthis("Subscribe returned not_found: $filename");
1.607 raeburn 1213: return 'not_found';
1.64 www 1214: } elsif ($remoteurl =~ /^rejected by/) {
1215: &logthis("Subscribe returned $remoteurl: $filename");
1.607 raeburn 1216: return 'forbidden';
1.20 www 1217: } elsif ($remoteurl eq 'directory') {
1.607 raeburn 1218: return 'ok';
1.8 www 1219: } else {
1.290 www 1220: my $author=$filename;
1221: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1222: my ($udom,$uname)=split(/\//,$author);
1223: my $home=homeserver($uname,$udom);
1224: unless ($home eq $perlvar{'lonHostID'}) {
1.8 www 1225: my @parts=split(/\//,$filename);
1226: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
1227: if ($path ne "$perlvar{'lonDocRoot'}/res") {
1228: &logthis("Malconfiguration for replication: $filename");
1.607 raeburn 1229: return 'bad_request';
1.8 www 1230: }
1231: my $count;
1232: for ($count=5;$count<$#parts;$count++) {
1233: $path.="/$parts[$count]";
1234: if ((-e $path)!=1) {
1235: mkdir($path,0777);
1236: }
1237: }
1238: my $ua=new LWP::UserAgent;
1239: my $request=new HTTP::Request('GET',"$remoteurl");
1240: my $response=$ua->request($request,$transname);
1241: if ($response->is_error()) {
1242: unlink($transname);
1243: my $message=$response->status_line;
1.672 albertel 1244: &logthis("<font color=\"blue\">WARNING:"
1.12 www 1245: ." LWP get: $message: $filename</font>");
1.607 raeburn 1246: return 'unavailable';
1.8 www 1247: } else {
1.16 www 1248: if ($remoteurl!~/\.meta$/) {
1249: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
1250: my $mresponse=$ua->request($mrequest,$filename.'.meta');
1251: if ($mresponse->is_error()) {
1252: unlink($filename.'.meta');
1253: &logthis(
1.672 albertel 1254: "<font color=\"yellow\">INFO: No metadata: $filename</font>");
1.16 www 1255: }
1256: }
1.8 www 1257: rename($transname,$filename);
1.607 raeburn 1258: return 'ok';
1.8 www 1259: }
1.290 www 1260: }
1.8 www 1261: }
1.330 www 1262: }
1263:
1264: # ------------------------------------------------ Get server side include body
1265: sub ssi_body {
1.381 albertel 1266: my ($filelink,%form)=@_;
1.606 matthew 1267: if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
1268: $form{'LONCAPA_INTERNAL_no_discussion'}='true';
1269: }
1.330 www 1270: my $output=($filelink=~/^http\:/?&externalssi($filelink):
1.381 albertel 1271: &ssi($filelink,%form));
1.778 albertel 1272: $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
1.451 albertel 1273: $output=~s/^.*?\<body[^\>]*\>//si;
1274: $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
1.330 www 1275: return $output;
1.8 www 1276: }
1277:
1.15 www 1278: # --------------------------------------------------------- Server Side Include
1279:
1.782 albertel 1280: sub absolute_url {
1281: my ($host_name) = @_;
1282: my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
1283: if ($host_name eq '') {
1284: $host_name = $ENV{'SERVER_NAME'};
1285: }
1286: return $protocol.$host_name;
1287: }
1288:
1.15 www 1289: sub ssi {
1290:
1.23 www 1291: my ($fn,%form)=@_;
1.15 www 1292:
1293: my $ua=new LWP::UserAgent;
1.23 www 1294:
1295: my $request;
1.711 albertel 1296:
1297: $form{'no_update_last_known'}=1;
1298:
1.23 www 1299: if (%form) {
1.782 albertel 1300: $request=new HTTP::Request('POST',&absolute_url().$fn);
1.201 albertel 1301: $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
1.23 www 1302: } else {
1.782 albertel 1303: $request=new HTTP::Request('GET',&absolute_url().$fn);
1.23 www 1304: }
1305:
1.15 www 1306: $request->header(Cookie => $ENV{'HTTP_COOKIE'});
1307: my $response=$ua->request($request);
1308:
1.324 www 1309: return $response->content;
1310: }
1311:
1312: sub externalssi {
1313: my ($url)=@_;
1314: my $ua=new LWP::UserAgent;
1315: my $request=new HTTP::Request('GET',$url);
1316: my $response=$ua->request($request);
1.15 www 1317: return $response->content;
1318: }
1.254 www 1319:
1.492 albertel 1320: # -------------------------------- Allow a /uploaded/ URI to be vouched for
1321:
1322: sub allowuploaded {
1323: my ($srcurl,$url)=@_;
1324: $url=&clutter(&declutter($url));
1325: my $dir=$url;
1326: $dir=~s/\/[^\/]+$//;
1327: my %httpref=();
1328: my $httpurl=&hreflocation('',$url);
1329: $httpref{'httpref.'.$httpurl}=$srcurl;
1330: &Apache::lonnet::appenv(%httpref);
1.254 www 1331: }
1.477 raeburn 1332:
1.478 albertel 1333: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
1.638 albertel 1334: # input: action, courseID, current domain, intended
1.637 raeburn 1335: # path to file, source of file, instruction to parse file for objects,
1336: # ref to hash for embedded objects,
1337: # ref to hash for codebase of java objects.
1338: #
1.485 raeburn 1339: # output: url to file (if action was uploaddoc),
1340: # ok if successful, or diagnostic message otherwise (if action was propagate or copy)
1.477 raeburn 1341: #
1.478 albertel 1342: # Allows directory structure to be used within lonUsers/../userfiles/ for a
1343: # course.
1.477 raeburn 1344: #
1.478 albertel 1345: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1346: # will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
1347: # course's home server.
1.477 raeburn 1348: #
1.478 albertel 1349: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
1350: # be copied from $source (current location) to
1351: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1352: # and will then be copied to
1353: # /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
1354: # course's home server.
1.485 raeburn 1355: #
1.481 raeburn 1356: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1.620 albertel 1357: # will be retrived from $env{form.uploaddoc} (from DOCS interface) to
1.481 raeburn 1358: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1359: # and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
1360: # in course's home server.
1.637 raeburn 1361: #
1.477 raeburn 1362:
1363: sub process_coursefile {
1.638 albertel 1364: my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
1.477 raeburn 1365: my $fetchresult;
1.638 albertel 1366: my $home=&homeserver($docuname,$docudom);
1.477 raeburn 1367: if ($action eq 'propagate') {
1.638 albertel 1368: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1369: $home);
1.481 raeburn 1370: } else {
1.477 raeburn 1371: my $fpath = '';
1372: my $fname = $file;
1.478 albertel 1373: ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
1.477 raeburn 1374: $fpath=$docudom.'/'.$docuname.'/'.$fpath;
1.637 raeburn 1375: my $filepath = &build_filepath($fpath);
1.481 raeburn 1376: if ($action eq 'copy') {
1377: if ($source eq '') {
1378: $fetchresult = 'no source file';
1379: return $fetchresult;
1380: } else {
1381: my $destination = $filepath.'/'.$fname;
1382: rename($source,$destination);
1383: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638 albertel 1384: $home);
1.481 raeburn 1385: }
1386: } elsif ($action eq 'uploaddoc') {
1387: open(my $fh,'>'.$filepath.'/'.$fname);
1.620 albertel 1388: print $fh $env{'form.'.$source};
1.481 raeburn 1389: close($fh);
1.637 raeburn 1390: if ($parser eq 'parse') {
1391: my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
1392: unless ($parse_result eq 'ok') {
1393: &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
1394: }
1395: }
1.477 raeburn 1396: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638 albertel 1397: $home);
1.481 raeburn 1398: if ($fetchresult eq 'ok') {
1399: return '/uploaded/'.$fpath.'/'.$fname;
1400: } else {
1401: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1.638 albertel 1402: ' to host '.$home.': '.$fetchresult);
1.481 raeburn 1403: return '/adm/notfound.html';
1404: }
1.477 raeburn 1405: }
1406: }
1.485 raeburn 1407: unless ( $fetchresult eq 'ok') {
1.477 raeburn 1408: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1.638 albertel 1409: ' to host '.$home.': '.$fetchresult);
1.477 raeburn 1410: }
1411: return $fetchresult;
1412: }
1413:
1.637 raeburn 1414: sub build_filepath {
1415: my ($fpath) = @_;
1416: my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
1417: unless ($fpath eq '') {
1418: my @parts=split('/',$fpath);
1419: foreach my $part (@parts) {
1420: $filepath.= '/'.$part;
1421: if ((-e $filepath)!=1) {
1422: mkdir($filepath,0777);
1423: }
1424: }
1425: }
1426: return $filepath;
1427: }
1428:
1429: sub store_edited_file {
1.638 albertel 1430: my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
1.637 raeburn 1431: my $file = $primary_url;
1432: $file =~ s#^/uploaded/$docudom/$docuname/##;
1433: my $fpath = '';
1434: my $fname = $file;
1435: ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
1436: $fpath=$docudom.'/'.$docuname.'/'.$fpath;
1437: my $filepath = &build_filepath($fpath);
1438: open(my $fh,'>'.$filepath.'/'.$fname);
1439: print $fh $content;
1440: close($fh);
1.638 albertel 1441: my $home=&homeserver($docuname,$docudom);
1.637 raeburn 1442: $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638 albertel 1443: $home);
1.637 raeburn 1444: if ($$fetchresult eq 'ok') {
1445: return '/uploaded/'.$fpath.'/'.$fname;
1446: } else {
1.638 albertel 1447: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1448: ' to host '.$home.': '.$$fetchresult);
1.637 raeburn 1449: return '/adm/notfound.html';
1450: }
1451: }
1452:
1.531 albertel 1453: sub clean_filename {
1.831 albertel 1454: my ($fname,$args)=@_;
1.315 www 1455: # Replace Windows backslashes by forward slashes
1.257 www 1456: $fname=~s/\\/\//g;
1.831 albertel 1457: if (!$args->{'keep_path'}) {
1458: # Get rid of everything but the actual filename
1459: $fname=~s/^.*\/([^\/]+)$/$1/;
1460: }
1.315 www 1461: # Replace spaces by underscores
1462: $fname=~s/\s+/\_/g;
1463: # Replace all other weird characters by nothing
1.831 albertel 1464: $fname=~s{[^/\w\.\-]}{}g;
1.540 albertel 1465: # Replace all .\d. sequences with _\d. so they no longer look like version
1466: # numbers
1467: $fname=~s/\.(\d+)(?=\.)/_$1/g;
1.531 albertel 1468: return $fname;
1469: }
1470:
1.608 albertel 1471: # --------------- Take an uploaded file and put it into the userfiles directory
1.686 albertel 1472: # input: $formname - the contents of the file are in $env{"form.$formname"}
1.719 banghart 1473: # the desired filenam is in $env{"form.$formname.filename"}
1.686 albertel 1474: # $coursedoc - if true up to the current course
1475: # if false
1476: # $subdir - directory in userfile to store the file into
1477: # $parser, $allfiles, $codebase - unknown
1478: #
1479: # output: url of file in userspace, or error: <message>
1480: # or /adm/notfound.html if failure to upload occurse
1.608 albertel 1481:
1482:
1.531 albertel 1483: sub userfileupload {
1.719 banghart 1484: my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
1.531 albertel 1485: if (!defined($subdir)) { $subdir='unknown'; }
1.620 albertel 1486: my $fname=$env{'form.'.$formname.'.filename'};
1.531 albertel 1487: $fname=&clean_filename($fname);
1.315 www 1488: # See if there is anything left
1.257 www 1489: unless ($fname) { return 'error: no uploaded file'; }
1.620 albertel 1490: chop($env{'form.'.$formname});
1.523 raeburn 1491: if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
1492: my $now = time;
1493: my $filepath = 'tmp/helprequests/'.$now;
1494: my @parts=split(/\//,$filepath);
1495: my $fullpath = $perlvar{'lonDaemons'};
1496: for (my $i=0;$i<@parts;$i++) {
1497: $fullpath .= '/'.$parts[$i];
1498: if ((-e $fullpath)!=1) {
1499: mkdir($fullpath,0777);
1500: }
1501: }
1502: open(my $fh,'>'.$fullpath.'/'.$fname);
1.620 albertel 1503: print $fh $env{'form.'.$formname};
1.523 raeburn 1504: close($fh);
1.741 raeburn 1505: return $fullpath.'/'.$fname;
1506: } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
1507: my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
1508: '_'.$env{'user.domain'}.'/pending';
1509: my @parts=split(/\//,$filepath);
1510: my $fullpath = $perlvar{'lonDaemons'};
1511: for (my $i=0;$i<@parts;$i++) {
1512: $fullpath .= '/'.$parts[$i];
1513: if ((-e $fullpath)!=1) {
1514: mkdir($fullpath,0777);
1515: }
1516: }
1517: open(my $fh,'>'.$fullpath.'/'.$fname);
1518: print $fh $env{'form.'.$formname};
1519: close($fh);
1520: return $fullpath.'/'.$fname;
1.523 raeburn 1521: }
1.719 banghart 1522:
1.258 www 1523: # Create the directory if not present
1.493 albertel 1524: $fname="$subdir/$fname";
1.259 www 1525: if ($coursedoc) {
1.638 albertel 1526: my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
1527: my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1.646 raeburn 1528: if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
1.638 albertel 1529: return &finishuserfileupload($docuname,$docudom,
1530: $formname,$fname,$parser,$allfiles,
1531: $codebase);
1.481 raeburn 1532: } else {
1.620 albertel 1533: $fname=$env{'form.folder'}.'/'.$fname;
1.638 albertel 1534: return &process_coursefile('uploaddoc',$docuname,$docudom,
1535: $fname,$formname,$parser,
1536: $allfiles,$codebase);
1.481 raeburn 1537: }
1.719 banghart 1538: } elsif (defined($destuname)) {
1539: my $docuname=$destuname;
1540: my $docudom=$destudom;
1541: return &finishuserfileupload($docuname,$docudom,$formname,
1542: $fname,$parser,$allfiles,$codebase);
1543:
1.259 www 1544: } else {
1.638 albertel 1545: my $docuname=$env{'user.name'};
1546: my $docudom=$env{'user.domain'};
1.714 raeburn 1547: if (exists($env{'form.group'})) {
1548: $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
1549: $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1550: }
1.638 albertel 1551: return &finishuserfileupload($docuname,$docudom,$formname,
1552: $fname,$parser,$allfiles,$codebase);
1.259 www 1553: }
1.271 www 1554: }
1555:
1556: sub finishuserfileupload {
1.638 albertel 1557: my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
1.477 raeburn 1558: my $path=$docudom.'/'.$docuname.'/';
1.258 www 1559: my $filepath=$perlvar{'lonDocRoot'};
1.494 albertel 1560: my ($fnamepath,$file);
1561: $file=$fname;
1562: if ($fname=~m|/|) {
1563: ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
1564: $path.=$fnamepath.'/';
1565: }
1.259 www 1566: my @parts=split(/\//,$filepath.'/userfiles/'.$path);
1.258 www 1567: my $count;
1568: for ($count=4;$count<=$#parts;$count++) {
1569: $filepath.="/$parts[$count]";
1570: if ((-e $filepath)!=1) {
1571: mkdir($filepath,0777);
1572: }
1573: }
1574: # Save the file
1575: {
1.701 albertel 1576: if (!open(FH,'>'.$filepath.'/'.$file)) {
1577: &logthis('Failed to create '.$filepath.'/'.$file);
1578: print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
1579: return '/adm/notfound.html';
1580: }
1581: if (!print FH ($env{'form.'.$formname})) {
1582: &logthis('Failed to write to '.$filepath.'/'.$file);
1583: print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
1584: return '/adm/notfound.html';
1585: }
1.570 albertel 1586: close(FH);
1.258 www 1587: }
1.637 raeburn 1588: if ($parser eq 'parse') {
1.638 albertel 1589: my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
1590: $codebase);
1.637 raeburn 1591: unless ($parse_result eq 'ok') {
1.638 albertel 1592: &logthis('Failed to parse '.$filepath.$file.
1593: ' for embedded media: '.$parse_result);
1.637 raeburn 1594: }
1595: }
1.259 www 1596: # Notify homeserver to grep it
1597: #
1.638 albertel 1598: my $docuhome=&homeserver($docuname,$docudom);
1.494 albertel 1599: my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
1.295 www 1600: if ($fetchresult eq 'ok') {
1.259 www 1601: #
1.258 www 1602: # Return the URL to it
1.494 albertel 1603: return '/uploaded/'.$path.$file;
1.263 www 1604: } else {
1.494 albertel 1605: &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
1606: ': '.$fetchresult);
1.263 www 1607: return '/adm/notfound.html';
1608: }
1.493 albertel 1609: }
1610:
1.637 raeburn 1611: sub extract_embedded_items {
1.648 raeburn 1612: my ($filepath,$file,$allfiles,$codebase,$content) = @_;
1.637 raeburn 1613: my @state = ();
1614: my %javafiles = (
1615: codebase => '',
1616: code => '',
1617: archive => ''
1618: );
1619: my %mediafiles = (
1620: src => '',
1621: movie => '',
1622: );
1.648 raeburn 1623: my $p;
1624: if ($content) {
1625: $p = HTML::LCParser->new($content);
1626: } else {
1627: $p = HTML::LCParser->new($filepath.'/'.$file);
1628: }
1.641 albertel 1629: while (my $t=$p->get_token()) {
1.640 albertel 1630: if ($t->[0] eq 'S') {
1631: my ($tagname, $attr) = ($t->[1],$t->[2]);
1632: push (@state, $tagname);
1.648 raeburn 1633: if (lc($tagname) eq 'allow') {
1634: &add_filetype($allfiles,$attr->{'src'},'src');
1635: }
1.640 albertel 1636: if (lc($tagname) eq 'img') {
1637: &add_filetype($allfiles,$attr->{'src'},'src');
1638: }
1.645 raeburn 1639: if (lc($tagname) eq 'script') {
1640: if ($attr->{'archive'} =~ /\.jar$/i) {
1641: &add_filetype($allfiles,$attr->{'archive'},'archive');
1642: } else {
1643: &add_filetype($allfiles,$attr->{'src'},'src');
1644: }
1645: }
1646: if (lc($tagname) eq 'link') {
1647: if (lc($attr->{'rel'}) eq 'stylesheet') {
1648: &add_filetype($allfiles,$attr->{'href'},'href');
1649: }
1650: }
1.640 albertel 1651: if (lc($tagname) eq 'object' ||
1652: (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
1653: foreach my $item (keys(%javafiles)) {
1654: $javafiles{$item} = '';
1655: }
1656: }
1657: if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
1658: my $name = lc($attr->{'name'});
1659: foreach my $item (keys(%javafiles)) {
1660: if ($name eq $item) {
1661: $javafiles{$item} = $attr->{'value'};
1662: last;
1663: }
1664: }
1665: foreach my $item (keys(%mediafiles)) {
1666: if ($name eq $item) {
1667: &add_filetype($allfiles, $attr->{'value'}, 'value');
1668: last;
1669: }
1670: }
1671: }
1672: if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
1673: foreach my $item (keys(%javafiles)) {
1674: if ($attr->{$item}) {
1675: $javafiles{$item} = $attr->{$item};
1676: last;
1677: }
1678: }
1679: foreach my $item (keys(%mediafiles)) {
1680: if ($attr->{$item}) {
1681: &add_filetype($allfiles,$attr->{$item},$item);
1682: last;
1683: }
1684: }
1685: }
1686: } elsif ($t->[0] eq 'E') {
1687: my ($tagname) = ($t->[1]);
1688: if ($javafiles{'codebase'} ne '') {
1689: $javafiles{'codebase'} .= '/';
1690: }
1691: if (lc($tagname) eq 'applet' ||
1692: lc($tagname) eq 'object' ||
1693: (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
1694: ) {
1695: foreach my $item (keys(%javafiles)) {
1696: if ($item ne 'codebase' && $javafiles{$item} ne '') {
1697: my $file=$javafiles{'codebase'}.$javafiles{$item};
1698: &add_filetype($allfiles,$file,$item);
1699: }
1700: }
1701: }
1702: pop @state;
1703: }
1704: }
1.637 raeburn 1705: return 'ok';
1706: }
1707:
1.639 albertel 1708: sub add_filetype {
1709: my ($allfiles,$file,$type)=@_;
1710: if (exists($allfiles->{$file})) {
1711: unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
1712: push(@{$allfiles->{$file}}, &escape($type));
1713: }
1714: } else {
1715: @{$allfiles->{$file}} = (&escape($type));
1.637 raeburn 1716: }
1717: }
1718:
1.493 albertel 1719: sub removeuploadedurl {
1720: my ($url)=@_;
1721: my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
1.613 albertel 1722: return &removeuserfile($uname,$udom,$fname);
1.490 albertel 1723: }
1724:
1725: sub removeuserfile {
1726: my ($docuname,$docudom,$fname)=@_;
1727: my $home=&homeserver($docuname,$docudom);
1.798 raeburn 1728: my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
1729: if ($result eq 'ok') {
1730: if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
1731: my $metafile = $fname.'.meta';
1732: my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
1.823 albertel 1733: my $url = "/uploaded/$docudom/$docuname/$fname";
1734: my ($file,$group) = (&parse_portfolio_url($url))[3,4];
1.821 raeburn 1735: my $sqlresult =
1.823 albertel 1736: &update_portfolio_table($docuname,$docudom,$file,
1.821 raeburn 1737: 'portfolio_metadata',$group,
1738: 'delete');
1.798 raeburn 1739: }
1740: }
1741: return $result;
1.257 www 1742: }
1.15 www 1743:
1.530 albertel 1744: sub mkdiruserfile {
1745: my ($docuname,$docudom,$dir)=@_;
1746: my $home=&homeserver($docuname,$docudom);
1747: return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
1748: }
1749:
1.531 albertel 1750: sub renameuserfile {
1751: my ($docuname,$docudom,$old,$new)=@_;
1752: my $home=&homeserver($docuname,$docudom);
1.798 raeburn 1753: my $result = &reply("renameuserfile:$docudom:$docuname:".
1754: &escape("$old").':'.&escape("$new"),$home);
1755: if ($result eq 'ok') {
1756: if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
1757: my $oldmeta = $old.'.meta';
1758: my $newmeta = $new.'.meta';
1759: my $metaresult =
1760: &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
1.823 albertel 1761: my $url = "/uploaded/$docudom/$docuname/$old";
1762: my ($file,$group) = (&parse_portfolio_url($url))[3,4];
1.821 raeburn 1763: my $sqlresult =
1.823 albertel 1764: &update_portfolio_table($docuname,$docudom,$file,
1.821 raeburn 1765: 'portfolio_metadata',$group,
1766: 'delete');
1.798 raeburn 1767: }
1768: }
1769: return $result;
1.531 albertel 1770: }
1771:
1.14 www 1772: # ------------------------------------------------------------------------- Log
1773:
1774: sub log {
1775: my ($dom,$nam,$hom,$what)=@_;
1.47 www 1776: return critical("log:$dom:$nam:$what",$hom);
1.157 www 1777: }
1778:
1779: # ------------------------------------------------------------------ Course Log
1.352 www 1780: #
1781: # This routine flushes several buffers of non-mission-critical nature
1782: #
1.157 www 1783:
1784: sub flushcourselogs {
1.352 www 1785: &logthis('Flushing log buffers');
1786: #
1787: # course logs
1788: # This is a log of all transactions in a course, which can be used
1789: # for data mining purposes
1790: #
1791: # It also collects the courseid database, which lists last transaction
1792: # times and course titles for all courseids
1793: #
1794: my %courseidbuffer=();
1.800 albertel 1795: foreach my $crsid (keys %courselogs) {
1.352 www 1796: if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
1.188 www 1797: &escape($courselogs{$crsid}),
1798: $coursehombuf{$crsid}) eq 'ok') {
1.157 www 1799: delete $courselogs{$crsid};
1800: } else {
1801: &logthis('Failed to flush log buffer for '.$crsid);
1802: if (length($courselogs{$crsid})>40000) {
1.672 albertel 1803: &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
1.157 www 1804: " exceeded maximum size, deleting.</font>");
1805: delete $courselogs{$crsid};
1806: }
1.352 www 1807: }
1808: if ($courseidbuffer{$coursehombuf{$crsid}}) {
1809: $courseidbuffer{$coursehombuf{$crsid}}.='&'.
1.516 raeburn 1810: &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
1.741 raeburn 1811: ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
1.352 www 1812: } else {
1813: $courseidbuffer{$coursehombuf{$crsid}}=
1.516 raeburn 1814: &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
1.741 raeburn 1815: ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
1.571 raeburn 1816: }
1.191 harris41 1817: }
1.352 www 1818: #
1819: # Write course id database (reverse lookup) to homeserver of courses
1820: # Is used in pickcourse
1821: #
1.800 albertel 1822: foreach my $crsid (keys(%courseidbuffer)) {
1823: &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
1.352 www 1824: }
1825: #
1826: # File accesses
1827: # Writes to the dynamic metadata of resources to get hit counts, etc.
1828: #
1.449 matthew 1829: foreach my $entry (keys(%accesshash)) {
1.458 matthew 1830: if ($entry =~ /___count$/) {
1831: my ($dom,$name);
1.807 albertel 1832: ($dom,$name,undef)=
1.811 albertel 1833: ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
1.458 matthew 1834: if (! defined($dom) || $dom eq '' ||
1835: ! defined($name) || $name eq '') {
1.620 albertel 1836: my $cid = $env{'request.course.id'};
1837: $dom = $env{'request.'.$cid.'.domain'};
1838: $name = $env{'request.'.$cid.'.num'};
1.458 matthew 1839: }
1.450 matthew 1840: my $value = $accesshash{$entry};
1841: my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
1842: my %temphash=($url => $value);
1.449 matthew 1843: my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
1844: if ($result eq 'ok') {
1845: delete $accesshash{$entry};
1846: } elsif ($result eq 'unknown_cmd') {
1847: # Target server has old code running on it.
1.450 matthew 1848: my %temphash=($entry => $value);
1.449 matthew 1849: if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
1850: delete $accesshash{$entry};
1851: }
1852: }
1853: } else {
1.811 albertel 1854: my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
1.450 matthew 1855: my %temphash=($entry => $accesshash{$entry});
1.449 matthew 1856: if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
1857: delete $accesshash{$entry};
1858: }
1.185 www 1859: }
1.191 harris41 1860: }
1.352 www 1861: #
1862: # Roles
1863: # Reverse lookup of user roles for course faculty/staff and co-authorship
1864: #
1.800 albertel 1865: foreach my $entry (keys(%userrolehash)) {
1.351 www 1866: my ($role,$uname,$udom,$runame,$rudom,$rsec)=
1.349 www 1867: split(/\:/,$entry);
1868: if (&Apache::lonnet::put('nohist_userroles',
1.351 www 1869: { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
1.349 www 1870: $rudom,$runame) eq 'ok') {
1871: delete $userrolehash{$entry};
1872: }
1873: }
1.662 raeburn 1874: #
1875: # Reverse lookup of domain roles (dc, ad, li, sc, au)
1876: #
1877: my %domrolebuffer = ();
1878: foreach my $entry (keys %domainrolehash) {
1879: my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
1880: if ($domrolebuffer{$rudom}) {
1881: $domrolebuffer{$rudom}.='&'.&escape($entry).
1882: '='.&escape($domainrolehash{$entry});
1883: } else {
1884: $domrolebuffer{$rudom}.=&escape($entry).
1885: '='.&escape($domainrolehash{$entry});
1886: }
1887: delete $domainrolehash{$entry};
1888: }
1889: foreach my $dom (keys(%domrolebuffer)) {
1890: foreach my $tryserver (keys %libserv) {
1891: if ($hostdom{$tryserver} eq $dom) {
1892: unless (&reply('domroleput:'.$dom.':'.
1893: $domrolebuffer{$dom},$tryserver) eq 'ok') {
1894: &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
1895: }
1896: }
1897: }
1898: }
1.186 www 1899: $dumpcount++;
1.157 www 1900: }
1901:
1902: sub courselog {
1903: my $what=shift;
1.158 www 1904: $what=time.':'.$what;
1.620 albertel 1905: unless ($env{'request.course.id'}) { return ''; }
1906: $coursedombuf{$env{'request.course.id'}}=
1907: $env{'course.'.$env{'request.course.id'}.'.domain'};
1908: $coursenumbuf{$env{'request.course.id'}}=
1909: $env{'course.'.$env{'request.course.id'}.'.num'};
1910: $coursehombuf{$env{'request.course.id'}}=
1911: $env{'course.'.$env{'request.course.id'}.'.home'};
1912: $coursedescrbuf{$env{'request.course.id'}}=
1913: $env{'course.'.$env{'request.course.id'}.'.description'};
1914: $courseinstcodebuf{$env{'request.course.id'}}=
1915: $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
1916: $courseownerbuf{$env{'request.course.id'}}=
1917: $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
1.741 raeburn 1918: $coursetypebuf{$env{'request.course.id'}}=
1919: $env{'course.'.$env{'request.course.id'}.'.type'};
1.620 albertel 1920: if (defined $courselogs{$env{'request.course.id'}}) {
1921: $courselogs{$env{'request.course.id'}}.='&'.$what;
1.157 www 1922: } else {
1.620 albertel 1923: $courselogs{$env{'request.course.id'}}.=$what;
1.157 www 1924: }
1.620 albertel 1925: if (length($courselogs{$env{'request.course.id'}})>4048) {
1.157 www 1926: &flushcourselogs();
1927: }
1.158 www 1928: }
1929:
1930: sub courseacclog {
1931: my $fnsymb=shift;
1.620 albertel 1932: unless ($env{'request.course.id'}) { return ''; }
1933: my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
1.657 albertel 1934: if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
1.187 www 1935: $what.=':POST';
1.583 matthew 1936: # FIXME: Probably ought to escape things....
1.800 albertel 1937: foreach my $key (keys(%env)) {
1938: if ($key=~/^form\.(.*)/) {
1939: $what.=':'.$1.'='.$env{$key};
1.158 www 1940: }
1.191 harris41 1941: }
1.583 matthew 1942: } elsif ($fnsymb =~ m:^/adm/searchcat:) {
1943: # FIXME: We should not be depending on a form parameter that someone
1944: # editing lonsearchcat.pm might change in the future.
1.620 albertel 1945: if ($env{'form.phase'} eq 'course_search') {
1.583 matthew 1946: $what.= ':POST';
1947: # FIXME: Probably ought to escape things....
1948: foreach my $element ('courseexp','crsfulltext','crsrelated',
1949: 'crsdiscuss') {
1.620 albertel 1950: $what.=':'.$element.'='.$env{'form.'.$element};
1.583 matthew 1951: }
1952: }
1.158 www 1953: }
1954: &courselog($what);
1.149 www 1955: }
1956:
1.185 www 1957: sub countacc {
1958: my $url=&declutter(shift);
1.458 matthew 1959: return if (! defined($url) || $url eq '');
1.620 albertel 1960: unless ($env{'request.course.id'}) { return ''; }
1961: $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
1.281 www 1962: my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
1.450 matthew 1963: $accesshash{$key}++;
1.185 www 1964: }
1.349 www 1965:
1.361 www 1966: sub linklog {
1967: my ($from,$to)=@_;
1968: $from=&declutter($from);
1969: $to=&declutter($to);
1970: $accesshash{$from.'___'.$to.'___comefrom'}=1;
1971: $accesshash{$to.'___'.$from.'___goto'}=1;
1972: }
1973:
1.349 www 1974: sub userrolelog {
1975: my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
1.661 raeburn 1976: if (($trole=~/^ca/) || ($trole=~/^aa/) ||
1.662 raeburn 1977: ($trole=~/^in/) || ($trole=~/^cc/) ||
1.661 raeburn 1978: ($trole=~/^ep/) || ($trole=~/^cr/) ||
1979: ($trole=~/^ta/)) {
1.350 www 1980: my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
1981: $userrolehash
1982: {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
1.349 www 1983: =$tend.':'.$tstart;
1.662 raeburn 1984: }
1985: if (($trole=~/^dc/) || ($trole=~/^ad/) ||
1986: ($trole=~/^li/) || ($trole=~/^li/) ||
1987: ($trole=~/^au/) || ($trole=~/^dg/) ||
1988: ($trole=~/^sc/)) {
1989: my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
1990: $domainrolehash
1991: {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
1992: = $tend.':'.$tstart;
1993: }
1.351 www 1994: }
1995:
1996: sub get_course_adv_roles {
1997: my $cid=shift;
1.620 albertel 1998: $cid=$env{'request.course.id'} unless (defined($cid));
1.351 www 1999: my %coursehash=&coursedescription($cid);
1.470 www 2000: my %nothide=();
1.800 albertel 2001: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
2002: $nothide{join(':',split(/[\@\:]/,$user))}=1;
1.470 www 2003: }
1.351 www 2004: my %returnhash=();
2005: my %dumphash=
2006: &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
2007: my $now=time;
1.800 albertel 2008: foreach my $entry (keys %dumphash) {
2009: my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
1.351 www 2010: if (($tstart) && ($tstart<0)) { next; }
2011: if (($tend) && ($tend<$now)) { next; }
2012: if (($tstart) && ($now<$tstart)) { next; }
1.800 albertel 2013: my ($role,$username,$domain,$section)=split(/\:/,$entry);
1.576 albertel 2014: if ($username eq '' || $domain eq '') { next; }
1.470 www 2015: if ((&privileged($username,$domain)) &&
2016: (!$nothide{$username.':'.$domain})) { next; }
1.656 albertel 2017: if ($role eq 'cr') { next; }
1.351 www 2018: my $key=&plaintext($role);
2019: if ($section) { $key.=' (Sec/Grp '.$section.')'; }
2020: if ($returnhash{$key}) {
2021: $returnhash{$key}.=','.$username.':'.$domain;
2022: } else {
2023: $returnhash{$key}=$username.':'.$domain;
2024: }
1.400 www 2025: }
2026: return %returnhash;
2027: }
2028:
2029: sub get_my_roles {
1.832 ! raeburn 2030: my ($uname,$udom,$types,$roles,$roledoms)=@_;
1.620 albertel 2031: unless (defined($uname)) { $uname=$env{'user.name'}; }
2032: unless (defined($udom)) { $udom=$env{'user.domain'}; }
1.400 www 2033: my %dumphash=
2034: &dump('nohist_userroles',$udom,$uname);
2035: my %returnhash=();
2036: my $now=time;
1.800 albertel 2037: foreach my $entry (keys(%dumphash)) {
2038: my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
1.400 www 2039: if (($tstart) && ($tstart<0)) { next; }
1.832 ! raeburn 2040: my $status = 'active';
! 2041: if (($tend) && ($tend<$now)) {
! 2042: $status = 'previous';
! 2043: }
! 2044: if (($tstart) && ($now<$tstart)) {
! 2045: $status = 'future';
! 2046: }
! 2047: if (ref($types) eq 'ARRAY') {
! 2048: if (!grep(/^\Q$status\E$/,@{$types})) {
! 2049: next;
! 2050: }
! 2051: } else {
! 2052: if ($status ne 'active') {
! 2053: next;
! 2054: }
! 2055: }
1.800 albertel 2056: my ($role,$username,$domain,$section)=split(/\:/,$entry);
1.832 ! raeburn 2057: if (ref($roledoms) eq 'ARRAY') {
! 2058: if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
! 2059: next;
! 2060: }
! 2061: }
! 2062: if (ref($roles) eq 'ARRAY') {
! 2063: if (!grep(/^\Q$role\E$/,@{$roles})) {
! 2064: next;
! 2065: }
! 2066: }
1.400 www 2067: $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
1.832 ! raeburn 2068: }
1.373 www 2069: return %returnhash;
1.399 www 2070: }
2071:
2072: # ----------------------------------------------------- Frontpage Announcements
2073: #
2074: #
2075:
2076: sub postannounce {
2077: my ($server,$text)=@_;
2078: unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
2079: unless ($text=~/\w/) { $text=''; }
2080: return &reply('setannounce:'.&escape($text),$server);
2081: }
2082:
2083: sub getannounce {
1.448 albertel 2084:
2085: if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
1.399 www 2086: my $announcement='';
1.800 albertel 2087: while (my $line = <$fh>) { $announcement .= $line; }
1.448 albertel 2088: close($fh);
1.399 www 2089: if ($announcement=~/\w/) {
2090: return
2091: '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
1.518 albertel 2092: '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>';
1.399 www 2093: } else {
2094: return '';
2095: }
2096: } else {
2097: return '';
2098: }
1.351 www 2099: }
1.353 www 2100:
2101: # ---------------------------------------------------------- Course ID routines
2102: # Deal with domain's nohist_courseid.db files
2103: #
2104:
2105: sub courseidput {
2106: my ($domain,$what,$coursehome)=@_;
2107: return &reply('courseidput:'.$domain.':'.$what,$coursehome);
2108: }
2109:
2110: sub courseiddump {
1.791 raeburn 2111: my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
1.353 www 2112: my %returnhash=();
1.355 www 2113: unless ($domfilter) { $domfilter=''; }
1.353 www 2114: foreach my $tryserver (keys %libserv) {
1.511 raeburn 2115: if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
1.506 raeburn 2116: if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
1.800 albertel 2117: foreach my $line (
1.506 raeburn 2118: split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
1.571 raeburn 2119: $sincefilter.':'.&escape($descfilter).':'.
1.791 raeburn 2120: &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
1.354 www 2121: $tryserver))) {
1.800 albertel 2122: my ($key,$value)=split(/\=/,$line,2);
1.506 raeburn 2123: if (($key) && ($value)) {
1.516 raeburn 2124: $returnhash{&unescape($key)}=$value;
1.506 raeburn 2125: }
1.353 www 2126: }
2127: }
2128: }
2129: }
2130: return %returnhash;
2131: }
2132:
1.658 raeburn 2133: # ---------------------------------------------------------- DC e-mail
1.662 raeburn 2134:
2135: sub dcmailput {
1.685 raeburn 2136: my ($domain,$msgid,$message,$server)=@_;
1.662 raeburn 2137: my $status = &Apache::lonnet::critical(
1.740 www 2138: 'dcmailput:'.$domain.':'.&escape($msgid).'='.
2139: &escape($message),$server);
1.662 raeburn 2140: return $status;
2141: }
2142:
1.658 raeburn 2143: sub dcmaildump {
2144: my ($dom,$startdate,$enddate,$senders) = @_;
1.685 raeburn 2145: my %returnhash=();
2146: if (exists($domain_primary{$dom})) {
2147: my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
2148: &escape($enddate).':';
2149: my @esc_senders=map { &escape($_)} @$senders;
2150: $cmd.=&escape(join('&',@esc_senders));
1.800 albertel 2151: foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
2152: my ($key,$value) = split(/\=/,$line,2);
1.685 raeburn 2153: if (($key) && ($value)) {
2154: $returnhash{&unescape($key)} = &unescape($value);
1.658 raeburn 2155: }
2156: }
2157: }
2158: return %returnhash;
2159: }
1.662 raeburn 2160: # ---------------------------------------------------------- Domain roles
2161:
2162: sub get_domain_roles {
2163: my ($dom,$roles,$startdate,$enddate)=@_;
2164: if (undef($startdate) || $startdate eq '') {
2165: $startdate = '.';
2166: }
2167: if (undef($enddate) || $enddate eq '') {
2168: $enddate = '.';
2169: }
2170: my $rolelist = join(':',@{$roles});
2171: my %personnel = ();
2172: foreach my $tryserver (keys(%libserv)) {
2173: if ($hostdom{$tryserver} eq $dom) {
2174: %{$personnel{$tryserver}}=();
1.800 albertel 2175: foreach my $line (
1.662 raeburn 2176: split(/\&/,&reply('domrolesdump:'.$dom.':'.
2177: &escape($startdate).':'.&escape($enddate).':'.
2178: &escape($rolelist), $tryserver))) {
1.800 albertel 2179: my ($key,$value) = split(/\=/,$line,2);
1.662 raeburn 2180: if (($key) && ($value)) {
2181: $personnel{$tryserver}{&unescape($key)} = &unescape($value);
2182: }
2183: }
2184: }
2185: }
2186: return %personnel;
2187: }
1.658 raeburn 2188:
1.149 www 2189: # ----------------------------------------------------------- Check out an item
2190:
1.504 albertel 2191: sub get_first_access {
2192: my ($type,$argsymb)=@_;
1.790 albertel 2193: my ($symb,$courseid,$udom,$uname)=&whichuser();
1.504 albertel 2194: if ($argsymb) { $symb=$argsymb; }
2195: my ($map,$id,$res)=&decode_symb($symb);
1.588 albertel 2196: if ($type eq 'map') {
2197: $res=&symbread($map);
2198: } else {
2199: $res=$symb;
2200: }
2201: my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
2202: return $times{"$courseid\0$res"};
1.504 albertel 2203: }
2204:
2205: sub set_first_access {
2206: my ($type)=@_;
1.790 albertel 2207: my ($symb,$courseid,$udom,$uname)=&whichuser();
1.504 albertel 2208: my ($map,$id,$res)=&decode_symb($symb);
1.588 albertel 2209: if ($type eq 'map') {
2210: $res=&symbread($map);
2211: } else {
2212: $res=$symb;
2213: }
2214: my $firstaccess=&get_first_access($type,$symb);
1.505 albertel 2215: if (!$firstaccess) {
1.588 albertel 2216: return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
1.505 albertel 2217: }
2218: return 'already_set';
1.504 albertel 2219: }
2220:
1.149 www 2221: sub checkout {
2222: my ($symb,$tuname,$tudom,$tcrsid)=@_;
2223: my $now=time;
2224: my $lonhost=$perlvar{'lonHostID'};
2225: my $infostr=&escape(
1.234 www 2226: 'CHECKOUTTOKEN&'.
1.149 www 2227: $tuname.'&'.
2228: $tudom.'&'.
2229: $tcrsid.'&'.
2230: $symb.'&'.
2231: $now.'&'.$ENV{'REMOTE_ADDR'});
2232: my $token=&reply('tmpput:'.$infostr,$lonhost);
1.151 www 2233: if ($token=~/^error\:/) {
1.672 albertel 2234: &logthis("<font color=\"blue\">WARNING: ".
1.151 www 2235: "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
2236: "</font>");
2237: return '';
2238: }
2239:
1.149 www 2240: $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
2241: $token=~tr/a-z/A-Z/;
2242:
1.153 www 2243: my %infohash=('resource.0.outtoken' => $token,
2244: 'resource.0.checkouttime' => $now,
2245: 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
1.149 www 2246:
2247: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
2248: return '';
1.151 www 2249: } else {
1.672 albertel 2250: &logthis("<font color=\"blue\">WARNING: ".
1.151 www 2251: "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
2252: "</font>");
1.149 www 2253: }
2254:
2255: if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
2256: &escape('Checkout '.$infostr.' - '.
2257: $token)) ne 'ok') {
2258: return '';
1.151 www 2259: } else {
1.672 albertel 2260: &logthis("<font color=\"blue\">WARNING: ".
1.151 www 2261: "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
2262: "</font>");
1.149 www 2263: }
1.151 www 2264: return $token;
1.149 www 2265: }
2266:
2267: # ------------------------------------------------------------ Check in an item
2268:
2269: sub checkin {
2270: my $token=shift;
1.150 www 2271: my $now=time;
2272: my ($ta,$tb,$lonhost)=split(/\*/,$token);
2273: $lonhost=~tr/A-Z/a-z/;
1.595 albertel 2274: my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
1.150 www 2275: $dtoken=~s/\W/\_/g;
1.234 www 2276: my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
1.150 www 2277: split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
2278:
1.154 www 2279: unless (($tuname) && ($tudom)) {
2280: &logthis('Check in '.$token.' ('.$dtoken.') failed');
2281: return '';
2282: }
2283:
2284: unless (&allowed('mgr',$tcrsid)) {
2285: &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
1.620 albertel 2286: $env{'user.name'}.' - '.$env{'user.domain'});
1.154 www 2287: return '';
2288: }
2289:
1.153 www 2290: my %infohash=('resource.0.intoken' => $token,
2291: 'resource.0.checkintime' => $now,
2292: 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
1.150 www 2293:
2294: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
2295: return '';
2296: }
2297:
2298: if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
2299: &escape('Checkin - '.$token)) ne 'ok') {
2300: return '';
2301: }
2302:
2303: return ($symb,$tuname,$tudom,$tcrsid);
1.110 www 2304: }
2305:
2306: # --------------------------------------------- Set Expire Date for Spreadsheet
2307:
2308: sub expirespread {
2309: my ($uname,$udom,$stype,$usymb)=@_;
1.620 albertel 2310: my $cid=$env{'request.course.id'};
1.110 www 2311: if ($cid) {
2312: my $now=time;
2313: my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
1.620 albertel 2314: return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'.
2315: $env{'course.'.$cid.'.num'}.
1.110 www 2316: ':nohist_expirationdates:'.
2317: &escape($key).'='.$now,
1.620 albertel 2318: $env{'course.'.$cid.'.home'})
1.110 www 2319: }
2320: return 'ok';
1.14 www 2321: }
2322:
1.109 www 2323: # ----------------------------------------------------- Devalidate Spreadsheets
2324:
2325: sub devalidate {
1.325 www 2326: my ($symb,$uname,$udom)=@_;
1.620 albertel 2327: my $cid=$env{'request.course.id'};
1.109 www 2328: if ($cid) {
1.391 matthew 2329: # delete the stored spreadsheets for
2330: # - the student level sheet of this user in course's homespace
2331: # - the assessment level sheet for this resource
2332: # for this user in user's homespace
1.553 albertel 2333: # - current conditional state info
1.325 www 2334: my $key=$uname.':'.$udom.':';
1.109 www 2335: my $status=
1.299 matthew 2336: &del('nohist_calculatedsheets',
1.391 matthew 2337: [$key.'studentcalc:'],
1.620 albertel 2338: $env{'course.'.$cid.'.domain'},
2339: $env{'course.'.$cid.'.num'})
1.133 albertel 2340: .' '.
2341: &del('nohist_calculatedsheets_'.$cid,
1.391 matthew 2342: [$key.'assesscalc:'.$symb],$udom,$uname);
1.109 www 2343: unless ($status eq 'ok ok') {
2344: &logthis('Could not devalidate spreadsheet '.
1.325 www 2345: $uname.' at '.$udom.' for '.
1.109 www 2346: $symb.': '.$status);
1.133 albertel 2347: }
1.553 albertel 2348: &delenv('user.state.'.$cid);
1.109 www 2349: }
2350: }
2351:
1.265 albertel 2352: sub get_scalar {
2353: my ($string,$end) = @_;
2354: my $value;
2355: if ($$string =~ s/^([^&]*?)($end)/$2/) {
2356: $value = $1;
2357: } elsif ($$string =~ s/^([^&]*?)&//) {
2358: $value = $1;
2359: }
2360: return &unescape($value);
2361: }
2362:
2363: sub array2str {
2364: my (@array) = @_;
2365: my $result=&arrayref2str(\@array);
2366: $result=~s/^__ARRAY_REF__//;
2367: $result=~s/__END_ARRAY_REF__$//;
2368: return $result;
2369: }
2370:
1.204 albertel 2371: sub arrayref2str {
2372: my ($arrayref) = @_;
1.265 albertel 2373: my $result='__ARRAY_REF__';
1.204 albertel 2374: foreach my $elem (@$arrayref) {
1.265 albertel 2375: if(ref($elem) eq 'ARRAY') {
2376: $result.=&arrayref2str($elem).'&';
2377: } elsif(ref($elem) eq 'HASH') {
2378: $result.=&hashref2str($elem).'&';
2379: } elsif(ref($elem)) {
2380: #print("Got a ref of ".(ref($elem))." skipping.");
1.204 albertel 2381: } else {
2382: $result.=&escape($elem).'&';
2383: }
2384: }
2385: $result=~s/\&$//;
1.265 albertel 2386: $result .= '__END_ARRAY_REF__';
1.204 albertel 2387: return $result;
2388: }
2389:
1.168 albertel 2390: sub hash2str {
1.204 albertel 2391: my (%hash) = @_;
2392: my $result=&hashref2str(\%hash);
1.265 albertel 2393: $result=~s/^__HASH_REF__//;
2394: $result=~s/__END_HASH_REF__$//;
1.204 albertel 2395: return $result;
2396: }
2397:
2398: sub hashref2str {
2399: my ($hashref)=@_;
1.265 albertel 2400: my $result='__HASH_REF__';
1.800 albertel 2401: foreach my $key (sort(keys(%$hashref))) {
2402: if (ref($key) eq 'ARRAY') {
2403: $result.=&arrayref2str($key).'=';
2404: } elsif (ref($key) eq 'HASH') {
2405: $result.=&hashref2str($key).'=';
2406: } elsif (ref($key)) {
1.265 albertel 2407: $result.='=';
1.800 albertel 2408: #print("Got a ref of ".(ref($key))." skipping.");
1.204 albertel 2409: } else {
1.800 albertel 2410: if ($key) {$result.=&escape($key).'=';} else { last; }
1.204 albertel 2411: }
2412:
1.800 albertel 2413: if(ref($hashref->{$key}) eq 'ARRAY') {
2414: $result.=&arrayref2str($hashref->{$key}).'&';
2415: } elsif(ref($hashref->{$key}) eq 'HASH') {
2416: $result.=&hashref2str($hashref->{$key}).'&';
2417: } elsif(ref($hashref->{$key})) {
1.265 albertel 2418: $result.='&';
1.800 albertel 2419: #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
1.204 albertel 2420: } else {
1.800 albertel 2421: $result.=&escape($hashref->{$key}).'&';
1.204 albertel 2422: }
2423: }
1.168 albertel 2424: $result=~s/\&$//;
1.265 albertel 2425: $result .= '__END_HASH_REF__';
1.168 albertel 2426: return $result;
2427: }
2428:
2429: sub str2hash {
1.265 albertel 2430: my ($string)=@_;
2431: my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
2432: return %$hash;
2433: }
2434:
2435: sub str2hashref {
1.168 albertel 2436: my ($string) = @_;
1.265 albertel 2437:
2438: my %hash;
2439:
2440: if($string !~ /^__HASH_REF__/) {
2441: if (! ($string eq '' || !defined($string))) {
2442: $hash{'error'}='Not hash reference';
2443: }
2444: return (\%hash, $string);
2445: }
2446:
2447: $string =~ s/^__HASH_REF__//;
2448:
2449: while($string !~ /^__END_HASH_REF__/) {
2450: #key
2451: my $key='';
2452: if($string =~ /^__HASH_REF__/) {
2453: ($key, $string)=&str2hashref($string);
2454: if(defined($key->{'error'})) {
2455: $hash{'error'}='Bad data';
2456: return (\%hash, $string);
2457: }
2458: } elsif($string =~ /^__ARRAY_REF__/) {
2459: ($key, $string)=&str2arrayref($string);
2460: if($key->[0] eq 'Array reference error') {
2461: $hash{'error'}='Bad data';
2462: return (\%hash, $string);
2463: }
2464: } else {
2465: $string =~ s/^(.*?)=//;
1.267 albertel 2466: $key=&unescape($1);
1.265 albertel 2467: }
2468: $string =~ s/^=//;
2469:
2470: #value
2471: my $value='';
2472: if($string =~ /^__HASH_REF__/) {
2473: ($value, $string)=&str2hashref($string);
2474: if(defined($value->{'error'})) {
2475: $hash{'error'}='Bad data';
2476: return (\%hash, $string);
2477: }
2478: } elsif($string =~ /^__ARRAY_REF__/) {
2479: ($value, $string)=&str2arrayref($string);
2480: if($value->[0] eq 'Array reference error') {
2481: $hash{'error'}='Bad data';
2482: return (\%hash, $string);
2483: }
2484: } else {
2485: $value=&get_scalar(\$string,'__END_HASH_REF__');
2486: }
2487: $string =~ s/^&//;
2488:
2489: $hash{$key}=$value;
1.204 albertel 2490: }
1.265 albertel 2491:
2492: $string =~ s/^__END_HASH_REF__//;
2493:
2494: return (\%hash, $string);
1.204 albertel 2495: }
2496:
2497: sub str2array {
1.265 albertel 2498: my ($string)=@_;
2499: my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
2500: return @$array;
2501: }
2502:
2503: sub str2arrayref {
1.204 albertel 2504: my ($string) = @_;
1.265 albertel 2505: my @array;
2506:
2507: if($string !~ /^__ARRAY_REF__/) {
2508: if (! ($string eq '' || !defined($string))) {
2509: $array[0]='Array reference error';
2510: }
2511: return (\@array, $string);
2512: }
2513:
2514: $string =~ s/^__ARRAY_REF__//;
2515:
2516: while($string !~ /^__END_ARRAY_REF__/) {
2517: my $value='';
2518: if($string =~ /^__HASH_REF__/) {
2519: ($value, $string)=&str2hashref($string);
2520: if(defined($value->{'error'})) {
2521: $array[0] ='Array reference error';
2522: return (\@array, $string);
2523: }
2524: } elsif($string =~ /^__ARRAY_REF__/) {
2525: ($value, $string)=&str2arrayref($string);
2526: if($value->[0] eq 'Array reference error') {
2527: $array[0] ='Array reference error';
2528: return (\@array, $string);
2529: }
2530: } else {
2531: $value=&get_scalar(\$string,'__END_ARRAY_REF__');
2532: }
2533: $string =~ s/^&//;
2534:
2535: push(@array, $value);
1.191 harris41 2536: }
1.265 albertel 2537:
2538: $string =~ s/^__END_ARRAY_REF__//;
2539:
2540: return (\@array, $string);
1.168 albertel 2541: }
2542:
1.167 albertel 2543: # -------------------------------------------------------------------Temp Store
2544:
1.168 albertel 2545: sub tmpreset {
2546: my ($symb,$namespace,$domain,$stuname) = @_;
2547: if (!$symb) {
2548: $symb=&symbread();
1.620 albertel 2549: if (!$symb) { $symb= $env{'request.url'}; }
1.168 albertel 2550: }
2551: $symb=escape($symb);
2552:
1.620 albertel 2553: if (!$namespace) { $namespace=$env{'request.state'}; }
1.168 albertel 2554: $namespace=~s/\//\_/g;
2555: $namespace=~s/\W//g;
2556:
1.620 albertel 2557: if (!$domain) { $domain=$env{'user.domain'}; }
2558: if (!$stuname) { $stuname=$env{'user.name'}; }
1.591 albertel 2559: if ($domain eq 'public' && $stuname eq 'public') {
2560: $stuname=$ENV{'REMOTE_ADDR'};
2561: }
1.168 albertel 2562: my $path=$perlvar{'lonDaemons'}.'/tmp';
2563: my %hash;
2564: if (tie(%hash,'GDBM_File',
2565: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256 albertel 2566: &GDBM_WRCREAT(),0640)) {
1.168 albertel 2567: foreach my $key (keys %hash) {
1.180 albertel 2568: if ($key=~ /:$symb/) {
1.168 albertel 2569: delete($hash{$key});
2570: }
2571: }
2572: }
2573: }
2574:
1.167 albertel 2575: sub tmpstore {
1.168 albertel 2576: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
2577:
2578: if (!$symb) {
2579: $symb=&symbread();
1.620 albertel 2580: if (!$symb) { $symb= $env{'request.url'}; }
1.168 albertel 2581: }
2582: $symb=escape($symb);
2583:
2584: if (!$namespace) {
2585: # I don't think we would ever want to store this for a course.
2586: # it seems this will only be used if we don't have a course.
1.620 albertel 2587: #$namespace=$env{'request.course.id'};
1.168 albertel 2588: #if (!$namespace) {
1.620 albertel 2589: $namespace=$env{'request.state'};
1.168 albertel 2590: #}
2591: }
2592: $namespace=~s/\//\_/g;
2593: $namespace=~s/\W//g;
1.620 albertel 2594: if (!$domain) { $domain=$env{'user.domain'}; }
2595: if (!$stuname) { $stuname=$env{'user.name'}; }
1.591 albertel 2596: if ($domain eq 'public' && $stuname eq 'public') {
2597: $stuname=$ENV{'REMOTE_ADDR'};
2598: }
1.168 albertel 2599: my $now=time;
2600: my %hash;
2601: my $path=$perlvar{'lonDaemons'}.'/tmp';
2602: if (tie(%hash,'GDBM_File',
2603: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256 albertel 2604: &GDBM_WRCREAT(),0640)) {
1.168 albertel 2605: $hash{"version:$symb"}++;
2606: my $version=$hash{"version:$symb"};
2607: my $allkeys='';
2608: foreach my $key (keys(%$storehash)) {
2609: $allkeys.=$key.':';
1.591 albertel 2610: $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
1.168 albertel 2611: }
2612: $hash{"$version:$symb:timestamp"}=$now;
2613: $allkeys.='timestamp';
2614: $hash{"$version:keys:$symb"}=$allkeys;
2615: if (untie(%hash)) {
2616: return 'ok';
2617: } else {
2618: return "error:$!";
2619: }
2620: } else {
2621: return "error:$!";
2622: }
2623: }
1.167 albertel 2624:
1.168 albertel 2625: # -----------------------------------------------------------------Temp Restore
1.167 albertel 2626:
1.168 albertel 2627: sub tmprestore {
2628: my ($symb,$namespace,$domain,$stuname) = @_;
1.167 albertel 2629:
1.168 albertel 2630: if (!$symb) {
2631: $symb=&symbread();
1.620 albertel 2632: if (!$symb) { $symb= $env{'request.url'}; }
1.168 albertel 2633: }
2634: $symb=escape($symb);
2635:
1.620 albertel 2636: if (!$namespace) { $namespace=$env{'request.state'}; }
1.591 albertel 2637:
1.620 albertel 2638: if (!$domain) { $domain=$env{'user.domain'}; }
2639: if (!$stuname) { $stuname=$env{'user.name'}; }
1.591 albertel 2640: if ($domain eq 'public' && $stuname eq 'public') {
2641: $stuname=$ENV{'REMOTE_ADDR'};
2642: }
1.168 albertel 2643: my %returnhash;
2644: $namespace=~s/\//\_/g;
2645: $namespace=~s/\W//g;
2646: my %hash;
2647: my $path=$perlvar{'lonDaemons'}.'/tmp';
2648: if (tie(%hash,'GDBM_File',
2649: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256 albertel 2650: &GDBM_READER(),0640)) {
1.168 albertel 2651: my $version=$hash{"version:$symb"};
2652: $returnhash{'version'}=$version;
2653: my $scope;
2654: for ($scope=1;$scope<=$version;$scope++) {
2655: my $vkeys=$hash{"$scope:keys:$symb"};
2656: my @keys=split(/:/,$vkeys);
2657: my $key;
2658: $returnhash{"$scope:keys"}=$vkeys;
2659: foreach $key (@keys) {
1.591 albertel 2660: $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
2661: $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
1.167 albertel 2662: }
2663: }
1.168 albertel 2664: if (!(untie(%hash))) {
2665: return "error:$!";
2666: }
2667: } else {
2668: return "error:$!";
2669: }
2670: return %returnhash;
1.167 albertel 2671: }
2672:
1.9 www 2673: # ----------------------------------------------------------------------- Store
2674:
2675: sub store {
1.124 www 2676: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
2677: my $home='';
2678:
1.168 albertel 2679: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 2680:
1.213 www 2681: $symb=&symbclean($symb);
1.122 albertel 2682: if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109 www 2683:
1.620 albertel 2684: if (!$domain) { $domain=$env{'user.domain'}; }
2685: if (!$stuname) { $stuname=$env{'user.name'}; }
1.325 www 2686:
2687: &devalidate($symb,$stuname,$domain);
1.109 www 2688:
2689: $symb=escape($symb);
1.187 www 2690: if (!$namespace) {
1.620 albertel 2691: unless ($namespace=$env{'request.course.id'}) {
1.187 www 2692: return '';
2693: }
2694: }
1.620 albertel 2695: if (!$home) { $home=$env{'user.home'}; }
1.447 www 2696:
2697: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
2698: $$storehash{'host'}=$perlvar{'lonHostID'};
2699:
1.12 www 2700: my $namevalue='';
1.800 albertel 2701: foreach my $key (keys(%$storehash)) {
2702: $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
1.191 harris41 2703: }
1.12 www 2704: $namevalue=~s/\&$//;
1.187 www 2705: &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
1.124 www 2706: return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.9 www 2707: }
2708:
1.47 www 2709: # -------------------------------------------------------------- Critical Store
2710:
2711: sub cstore {
1.124 www 2712: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
2713: my $home='';
2714:
1.168 albertel 2715: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 2716:
1.213 www 2717: $symb=&symbclean($symb);
1.122 albertel 2718: if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109 www 2719:
1.620 albertel 2720: if (!$domain) { $domain=$env{'user.domain'}; }
2721: if (!$stuname) { $stuname=$env{'user.name'}; }
1.325 www 2722:
2723: &devalidate($symb,$stuname,$domain);
1.109 www 2724:
2725: $symb=escape($symb);
1.187 www 2726: if (!$namespace) {
1.620 albertel 2727: unless ($namespace=$env{'request.course.id'}) {
1.187 www 2728: return '';
2729: }
2730: }
1.620 albertel 2731: if (!$home) { $home=$env{'user.home'}; }
1.447 www 2732:
2733: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
2734: $$storehash{'host'}=$perlvar{'lonHostID'};
1.122 albertel 2735:
1.47 www 2736: my $namevalue='';
1.800 albertel 2737: foreach my $key (keys(%$storehash)) {
2738: $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
1.191 harris41 2739: }
1.47 www 2740: $namevalue=~s/\&$//;
1.187 www 2741: &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
1.188 www 2742: return critical
2743: ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.47 www 2744: }
2745:
1.9 www 2746: # --------------------------------------------------------------------- Restore
2747:
2748: sub restore {
1.124 www 2749: my ($symb,$namespace,$domain,$stuname) = @_;
2750: my $home='';
2751:
1.168 albertel 2752: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 2753:
1.122 albertel 2754: if (!$symb) {
2755: unless ($symb=escape(&symbread())) { return ''; }
2756: } else {
1.213 www 2757: $symb=&escape(&symbclean($symb));
1.122 albertel 2758: }
1.188 www 2759: if (!$namespace) {
1.620 albertel 2760: unless ($namespace=$env{'request.course.id'}) {
1.188 www 2761: return '';
2762: }
2763: }
1.620 albertel 2764: if (!$domain) { $domain=$env{'user.domain'}; }
2765: if (!$stuname) { $stuname=$env{'user.name'}; }
2766: if (!$home) { $home=$env{'user.home'}; }
1.122 albertel 2767: my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
2768:
1.12 www 2769: my %returnhash=();
1.800 albertel 2770: foreach my $line (split(/\&/,$answer)) {
2771: my ($name,$value)=split(/\=/,$line);
1.591 albertel 2772: $returnhash{&unescape($name)}=&thaw_unescape($value);
1.191 harris41 2773: }
1.75 www 2774: my $version;
2775: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.800 albertel 2776: foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
2777: $returnhash{$item}=$returnhash{$version.':'.$item};
1.191 harris41 2778: }
1.75 www 2779: }
1.13 www 2780: return %returnhash;
1.34 www 2781: }
2782:
2783: # ---------------------------------------------------------- Course Description
2784:
2785: sub coursedescription {
1.731 albertel 2786: my ($courseid,$args)=@_;
1.34 www 2787: $courseid=~s/^\///;
1.49 www 2788: $courseid=~s/\_/\//g;
1.34 www 2789: my ($cdomain,$cnum)=split(/\//,$courseid);
1.129 albertel 2790: my $chome=&homeserver($cnum,$cdomain);
1.302 albertel 2791: my $normalid=$cdomain.'_'.$cnum;
2792: # need to always cache even if we get errors otherwise we keep
2793: # trying and trying and trying to get the course description.
2794: my %envhash=();
2795: my %returnhash=();
1.731 albertel 2796:
2797: my $expiretime=600;
2798: if ($env{'request.course.id'} eq $normalid) {
2799: $expiretime=120;
2800: }
2801:
2802: my $prefix='course.'.$cdomain.'_'.$cnum.'.';
2803: if (!$args->{'freshen_cache'}
2804: && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
2805: foreach my $key (keys(%env)) {
2806: next if ($key !~ /^\Q$prefix\E(.*)/);
2807: my ($setting) = $1;
2808: $returnhash{$setting} = $env{$key};
2809: }
2810: return %returnhash;
2811: }
2812:
2813: # get the data agin
2814: if (!$args->{'one_time'}) {
2815: $envhash{'course.'.$normalid.'.last_cache'}=time;
2816: }
1.811 albertel 2817:
1.34 www 2818: if ($chome ne 'no_host') {
1.302 albertel 2819: %returnhash=&dump('environment',$cdomain,$cnum);
1.129 albertel 2820: if (!exists($returnhash{'con_lost'})) {
2821: $returnhash{'home'}= $chome;
2822: $returnhash{'domain'} = $cdomain;
2823: $returnhash{'num'} = $cnum;
1.741 raeburn 2824: if (!defined($returnhash{'type'})) {
2825: $returnhash{'type'} = 'Course';
2826: }
1.130 albertel 2827: while (my ($name,$value) = each %returnhash) {
1.53 www 2828: $envhash{'course.'.$normalid.'.'.$name}=$value;
1.129 albertel 2829: }
1.270 www 2830: $returnhash{'url'}=&clutter($returnhash{'url'});
1.34 www 2831: $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.620 albertel 2832: $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.60 www 2833: $envhash{'course.'.$normalid.'.home'}=$chome;
2834: $envhash{'course.'.$normalid.'.domain'}=$cdomain;
2835: $envhash{'course.'.$normalid.'.num'}=$cnum;
1.34 www 2836: }
2837: }
1.731 albertel 2838: if (!$args->{'one_time'}) {
2839: &appenv(%envhash);
2840: }
1.302 albertel 2841: return %returnhash;
1.461 www 2842: }
2843:
2844: # -------------------------------------------------See if a user is privileged
2845:
2846: sub privileged {
2847: my ($username,$domain)=@_;
2848: my $rolesdump=&reply("dump:$domain:$username:roles",
2849: &homeserver($username,$domain));
2850: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
2851: my $now=time;
2852: if ($rolesdump ne '') {
1.800 albertel 2853: foreach my $entry (split(/&/,$rolesdump)) {
2854: if ($entry!~/^rolesdef_/) {
2855: my ($area,$role)=split(/=/,$entry);
1.461 www 2856: $area=~s/\_\w\w$//;
2857: my ($trole,$tend,$tstart)=split(/_/,$role);
2858: if (($trole eq 'dc') || ($trole eq 'su')) {
2859: my $active=1;
2860: if ($tend) {
2861: if ($tend<$now) { $active=0; }
2862: }
2863: if ($tstart) {
2864: if ($tstart>$now) { $active=0; }
2865: }
2866: if ($active) { return 1; }
2867: }
2868: }
2869: }
2870: }
2871: return 0;
1.9 www 2872: }
1.1 albertel 2873:
1.103 harris41 2874: # -------------------------------------------------------- Get user privileges
1.11 www 2875:
2876: sub rolesinit {
2877: my ($domain,$username,$authhost)=@_;
2878: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12 www 2879: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11 www 2880: my %allroles=();
1.678 raeburn 2881: my %allgroups=();
1.11 www 2882: my $now=time;
1.743 albertel 2883: my %userroles = ('user.login.time' => $now);
1.678 raeburn 2884: my $group_privs;
1.11 www 2885:
2886: if ($rolesdump ne '') {
1.800 albertel 2887: foreach my $entry (split(/&/,$rolesdump)) {
2888: if ($entry!~/^rolesdef_/) {
2889: my ($area,$role)=split(/=/,$entry);
1.587 albertel 2890: $area=~s/\_\w\w$//;
1.678 raeburn 2891: my ($trole,$tend,$tstart,$group_privs);
1.587 albertel 2892: if ($role=~/^cr/) {
1.807 albertel 2893: if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
2894: ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
1.655 albertel 2895: ($tend,$tstart)=split('_',$trest);
2896: } else {
2897: $trole=$role;
2898: }
1.678 raeburn 2899: } elsif ($role =~ m|^gr/|) {
2900: ($trole,$tend,$tstart) = split(/_/,$role);
2901: ($trole,$group_privs) = split(/\//,$trole);
2902: $group_privs = &unescape($group_privs);
1.587 albertel 2903: } else {
2904: ($trole,$tend,$tstart)=split(/_/,$role);
2905: }
1.743 albertel 2906: my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
2907: $username);
2908: @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
1.567 raeburn 2909: if (($tend!=0) && ($tend<$now)) { $trole=''; }
2910: if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
1.11 www 2911: if (($area ne '') && ($trole ne '')) {
1.347 albertel 2912: my $spec=$trole.'.'.$area;
2913: my ($tdummy,$tdomain,$trest)=split(/\//,$area);
2914: if ($trole =~ /^cr\//) {
1.567 raeburn 2915: &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
1.678 raeburn 2916: } elsif ($trole eq 'gr') {
2917: &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
1.347 albertel 2918: } else {
1.567 raeburn 2919: &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
1.347 albertel 2920: }
1.12 www 2921: }
1.662 raeburn 2922: }
1.191 harris41 2923: }
1.743 albertel 2924: my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
2925: $userroles{'user.adv'} = $adv;
2926: $userroles{'user.author'} = $author;
1.620 albertel 2927: $env{'user.adv'}=$adv;
1.11 www 2928: }
1.743 albertel 2929: return \%userroles;
1.11 www 2930: }
2931:
1.567 raeburn 2932: sub set_arearole {
2933: my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
2934: # log the associated role with the area
2935: &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
1.743 albertel 2936: return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
1.567 raeburn 2937: }
2938:
2939: sub custom_roleprivs {
2940: my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
2941: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
2942: my $homsvr=homeserver($rauthor,$rdomain);
2943: if ($hostname{$homsvr} ne '') {
2944: my ($rdummy,$roledef)=
2945: &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
2946: if (($rdummy ne 'con_lost') && ($roledef ne '')) {
2947: my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
2948: if (defined($syspriv)) {
2949: $$allroles{'cm./'}.=':'.$syspriv;
2950: $$allroles{$spec.'./'}.=':'.$syspriv;
2951: }
2952: if ($tdomain ne '') {
2953: if (defined($dompriv)) {
2954: $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
2955: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
2956: }
2957: if (($trest ne '') && (defined($coursepriv))) {
2958: $$allroles{'cm.'.$area}.=':'.$coursepriv;
2959: $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
2960: }
2961: }
2962: }
2963: }
2964: }
2965:
1.678 raeburn 2966: sub group_roleprivs {
2967: my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
2968: my $access = 1;
2969: my $now = time;
2970: if (($tend!=0) && ($tend<$now)) { $access = 0; }
2971: if (($tstart!=0) && ($tstart>$now)) { $access=0; }
2972: if ($access) {
1.811 albertel 2973: my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
1.678 raeburn 2974: $$allgroups{$course}{$group} .=':'.$group_privs;
2975: }
2976: }
1.567 raeburn 2977:
2978: sub standard_roleprivs {
2979: my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
2980: if (defined($pr{$trole.':s'})) {
2981: $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
2982: $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
2983: }
2984: if ($tdomain ne '') {
2985: if (defined($pr{$trole.':d'})) {
2986: $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
2987: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
2988: }
2989: if (($trest ne '') && (defined($pr{$trole.':c'}))) {
2990: $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
2991: $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
2992: }
2993: }
2994: }
2995:
2996: sub set_userprivs {
1.678 raeburn 2997: my ($userroles,$allroles,$allgroups) = @_;
1.567 raeburn 2998: my $author=0;
2999: my $adv=0;
1.678 raeburn 3000: my %grouproles = ();
3001: if (keys(%{$allgroups}) > 0) {
3002: foreach my $role (keys %{$allroles}) {
1.681 raeburn 3003: my ($trole,$area,$sec,$extendedarea);
1.811 albertel 3004: if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
1.678 raeburn 3005: $trole = $1;
3006: $area = $2;
1.681 raeburn 3007: $sec = $3;
3008: $extendedarea = $area.$sec;
3009: if (exists($$allgroups{$area})) {
3010: foreach my $group (keys(%{$$allgroups{$area}})) {
3011: my $spec = $trole.'.'.$extendedarea;
3012: $grouproles{$spec.'.'.$area.'/'.$group} =
3013: $$allgroups{$area}{$group};
1.678 raeburn 3014: }
3015: }
3016: }
3017: }
3018: }
1.800 albertel 3019: foreach my $group (keys(%grouproles)) {
3020: $$allroles{$group} = $grouproles{$group};
1.678 raeburn 3021: }
1.800 albertel 3022: foreach my $role (keys(%{$allroles})) {
3023: my %thesepriv;
3024: if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
3025: foreach my $item (split(/:/,$$allroles{$role})) {
3026: if ($item ne '') {
3027: my ($privilege,$restrictions)=split(/&/,$item);
1.567 raeburn 3028: if ($restrictions eq '') {
3029: $thesepriv{$privilege}='F';
3030: } elsif ($thesepriv{$privilege} ne 'F') {
3031: $thesepriv{$privilege}.=$restrictions;
3032: }
3033: if ($thesepriv{'adv'} eq 'F') { $adv=1; }
3034: }
3035: }
3036: my $thesestr='';
1.800 albertel 3037: foreach my $priv (keys(%thesepriv)) {
3038: $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
3039: }
3040: $userroles->{'user.priv.'.$role} = $thesestr;
1.567 raeburn 3041: }
3042: return ($author,$adv);
3043: }
3044:
1.12 www 3045: # --------------------------------------------------------------- get interface
3046:
3047: sub get {
1.131 albertel 3048: my ($namespace,$storearr,$udomain,$uname)=@_;
1.12 www 3049: my $items='';
1.800 albertel 3050: foreach my $item (@$storearr) {
3051: $items.=&escape($item).'&';
1.191 harris41 3052: }
1.12 www 3053: $items=~s/\&$//;
1.620 albertel 3054: if (!$udomain) { $udomain=$env{'user.domain'}; }
3055: if (!$uname) { $uname=$env{'user.name'}; }
1.131 albertel 3056: my $uhome=&homeserver($uname,$udomain);
3057:
1.133 albertel 3058: my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
1.15 www 3059: my @pairs=split(/\&/,$rep);
1.273 albertel 3060: if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
3061: return @pairs;
3062: }
1.15 www 3063: my %returnhash=();
1.42 www 3064: my $i=0;
1.800 albertel 3065: foreach my $item (@$storearr) {
3066: $returnhash{$item}=&thaw_unescape($pairs[$i]);
1.42 www 3067: $i++;
1.191 harris41 3068: }
1.15 www 3069: return %returnhash;
1.27 www 3070: }
3071:
3072: # --------------------------------------------------------------- del interface
3073:
3074: sub del {
1.133 albertel 3075: my ($namespace,$storearr,$udomain,$uname)=@_;
1.27 www 3076: my $items='';
1.800 albertel 3077: foreach my $item (@$storearr) {
3078: $items.=&escape($item).'&';
1.191 harris41 3079: }
1.27 www 3080: $items=~s/\&$//;
1.620 albertel 3081: if (!$udomain) { $udomain=$env{'user.domain'}; }
3082: if (!$uname) { $uname=$env{'user.name'}; }
1.133 albertel 3083: my $uhome=&homeserver($uname,$udomain);
3084:
3085: return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
1.15 www 3086: }
3087:
3088: # -------------------------------------------------------------- dump interface
3089:
3090: sub dump {
1.755 albertel 3091: my ($namespace,$udomain,$uname,$regexp,$range)=@_;
3092: if (!$udomain) { $udomain=$env{'user.domain'}; }
3093: if (!$uname) { $uname=$env{'user.name'}; }
3094: my $uhome=&homeserver($uname,$udomain);
3095: if ($regexp) {
3096: $regexp=&escape($regexp);
3097: } else {
3098: $regexp='.';
3099: }
3100: my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
3101: my @pairs=split(/\&/,$rep);
3102: my %returnhash=();
3103: foreach my $item (@pairs) {
3104: my ($key,$value)=split(/=/,$item,2);
3105: $key = &unescape($key);
3106: next if ($key =~ /^error: 2 /);
3107: $returnhash{$key}=&thaw_unescape($value);
3108: }
3109: return %returnhash;
1.407 www 3110: }
3111:
1.717 albertel 3112: # --------------------------------------------------------- dumpstore interface
3113:
3114: sub dumpstore {
3115: my ($namespace,$udomain,$uname,$regexp,$range)=@_;
1.822 albertel 3116: if (!$udomain) { $udomain=$env{'user.domain'}; }
3117: if (!$uname) { $uname=$env{'user.name'}; }
3118: my $uhome=&homeserver($uname,$udomain);
3119: if ($regexp) {
3120: $regexp=&escape($regexp);
3121: } else {
3122: $regexp='.';
3123: }
3124: my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
3125: my @pairs=split(/\&/,$rep);
3126: my %returnhash=();
3127: foreach my $item (@pairs) {
3128: my ($key,$value)=split(/=/,$item,2);
3129: next if ($key =~ /^error: 2 /);
3130: $returnhash{$key}=&thaw_unescape($value);
3131: }
3132: return %returnhash;
1.717 albertel 3133: }
3134:
1.407 www 3135: # -------------------------------------------------------------- keys interface
3136:
3137: sub getkeys {
3138: my ($namespace,$udomain,$uname)=@_;
1.620 albertel 3139: if (!$udomain) { $udomain=$env{'user.domain'}; }
3140: if (!$uname) { $uname=$env{'user.name'}; }
1.407 www 3141: my $uhome=&homeserver($uname,$udomain);
3142: my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
3143: my @keyarray=();
1.800 albertel 3144: foreach my $key (split(/\&/,$rep)) {
1.812 raeburn 3145: next if ($key =~ /^error: 2 /);
1.800 albertel 3146: push(@keyarray,&unescape($key));
1.407 www 3147: }
3148: return @keyarray;
1.318 matthew 3149: }
3150:
1.319 matthew 3151: # --------------------------------------------------------------- currentdump
3152: sub currentdump {
1.328 matthew 3153: my ($courseid,$sdom,$sname)=@_;
1.620 albertel 3154: $courseid = $env{'request.course.id'} if (! defined($courseid));
3155: $sdom = $env{'user.domain'} if (! defined($sdom));
3156: $sname = $env{'user.name'} if (! defined($sname));
1.326 matthew 3157: my $uhome = &homeserver($sname,$sdom);
3158: my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
1.318 matthew 3159: return if ($rep =~ /^(error:|no_such_host)/);
1.319 matthew 3160: #
1.318 matthew 3161: my %returnhash=();
1.319 matthew 3162: #
3163: if ($rep eq "unknown_cmd") {
3164: # an old lond will not know currentdump
3165: # Do a dump and make it look like a currentdump
1.822 albertel 3166: my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
1.319 matthew 3167: return if ($tmp[0] =~ /^(error:|no_such_host)/);
3168: my %hash = @tmp;
3169: @tmp=();
1.424 matthew 3170: %returnhash = %{&convert_dump_to_currentdump(\%hash)};
1.319 matthew 3171: } else {
3172: my @pairs=split(/\&/,$rep);
1.800 albertel 3173: foreach my $pair (@pairs) {
3174: my ($key,$value)=split(/=/,$pair,2);
1.319 matthew 3175: my ($symb,$param) = split(/:/,$key);
3176: $returnhash{&unescape($symb)}->{&unescape($param)} =
1.557 albertel 3177: &thaw_unescape($value);
1.319 matthew 3178: }
1.191 harris41 3179: }
1.12 www 3180: return %returnhash;
1.424 matthew 3181: }
3182:
3183: sub convert_dump_to_currentdump{
3184: my %hash = %{shift()};
3185: my %returnhash;
3186: # Code ripped from lond, essentially. The only difference
3187: # here is the unescaping done by lonnet::dump(). Conceivably
3188: # we might run in to problems with parameter names =~ /^v\./
3189: while (my ($key,$value) = each(%hash)) {
3190: my ($v,$symb,$param) = split(/:/,$key);
1.822 albertel 3191: $symb = &unescape($symb);
3192: $param = &unescape($param);
1.424 matthew 3193: next if ($v eq 'version' || $symb eq 'keys');
3194: next if (exists($returnhash{$symb}) &&
3195: exists($returnhash{$symb}->{$param}) &&
3196: $returnhash{$symb}->{'v.'.$param} > $v);
3197: $returnhash{$symb}->{$param}=$value;
3198: $returnhash{$symb}->{'v.'.$param}=$v;
3199: }
3200: #
3201: # Remove all of the keys in the hashes which keep track of
3202: # the version of the parameter.
3203: while (my ($symb,$param_hash) = each(%returnhash)) {
3204: # use a foreach because we are going to delete from the hash.
3205: foreach my $key (keys(%$param_hash)) {
3206: delete($param_hash->{$key}) if ($key =~ /^v\./);
3207: }
3208: }
3209: return \%returnhash;
1.12 www 3210: }
3211:
1.627 albertel 3212: # ------------------------------------------------------ critical inc interface
3213:
3214: sub cinc {
3215: return &inc(@_,'critical');
3216: }
3217:
1.449 matthew 3218: # --------------------------------------------------------------- inc interface
3219:
3220: sub inc {
1.627 albertel 3221: my ($namespace,$store,$udomain,$uname,$critical) = @_;
1.620 albertel 3222: if (!$udomain) { $udomain=$env{'user.domain'}; }
3223: if (!$uname) { $uname=$env{'user.name'}; }
1.449 matthew 3224: my $uhome=&homeserver($uname,$udomain);
3225: my $items='';
3226: if (! ref($store)) {
3227: # got a single value, so use that instead
3228: $items = &escape($store).'=&';
3229: } elsif (ref($store) eq 'SCALAR') {
3230: $items = &escape($$store).'=&';
3231: } elsif (ref($store) eq 'ARRAY') {
3232: $items = join('=&',map {&escape($_);} @{$store});
3233: } elsif (ref($store) eq 'HASH') {
3234: while (my($key,$value) = each(%{$store})) {
3235: $items.= &escape($key).'='.&escape($value).'&';
3236: }
3237: }
3238: $items=~s/\&$//;
1.627 albertel 3239: if ($critical) {
3240: return &critical("inc:$udomain:$uname:$namespace:$items",$uhome);
3241: } else {
3242: return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
3243: }
1.449 matthew 3244: }
3245:
1.12 www 3246: # --------------------------------------------------------------- put interface
3247:
3248: sub put {
1.134 albertel 3249: my ($namespace,$storehash,$udomain,$uname)=@_;
1.620 albertel 3250: if (!$udomain) { $udomain=$env{'user.domain'}; }
3251: if (!$uname) { $uname=$env{'user.name'}; }
1.134 albertel 3252: my $uhome=&homeserver($uname,$udomain);
1.12 www 3253: my $items='';
1.800 albertel 3254: foreach my $item (keys(%$storehash)) {
3255: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.191 harris41 3256: }
1.12 www 3257: $items=~s/\&$//;
1.134 albertel 3258: return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.47 www 3259: }
3260:
1.631 albertel 3261: # ------------------------------------------------------------ newput interface
3262:
3263: sub newput {
3264: my ($namespace,$storehash,$udomain,$uname)=@_;
3265: if (!$udomain) { $udomain=$env{'user.domain'}; }
3266: if (!$uname) { $uname=$env{'user.name'}; }
3267: my $uhome=&homeserver($uname,$udomain);
3268: my $items='';
3269: foreach my $key (keys(%$storehash)) {
3270: $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
3271: }
3272: $items=~s/\&$//;
3273: return &reply("newput:$udomain:$uname:$namespace:$items",$uhome);
3274: }
3275:
3276: # --------------------------------------------------------- putstore interface
3277:
1.524 raeburn 3278: sub putstore {
1.715 albertel 3279: my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
1.620 albertel 3280: if (!$udomain) { $udomain=$env{'user.domain'}; }
3281: if (!$uname) { $uname=$env{'user.name'}; }
1.524 raeburn 3282: my $uhome=&homeserver($uname,$udomain);
3283: my $items='';
1.715 albertel 3284: foreach my $key (keys(%$storehash)) {
3285: $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
1.524 raeburn 3286: }
1.715 albertel 3287: $items=~s/\&$//;
1.716 albertel 3288: my $esc_symb=&escape($symb);
3289: my $esc_v=&escape($version);
1.715 albertel 3290: my $reply =
1.716 albertel 3291: &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
1.715 albertel 3292: $uhome);
3293: if ($reply eq 'unknown_cmd') {
1.716 albertel 3294: # gfall back to way things use to be done
1.715 albertel 3295: return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
3296: $uname);
1.524 raeburn 3297: }
1.715 albertel 3298: return $reply;
3299: }
3300:
3301: sub old_putstore {
1.716 albertel 3302: my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
3303: if (!$udomain) { $udomain=$env{'user.domain'}; }
3304: if (!$uname) { $uname=$env{'user.name'}; }
3305: my $uhome=&homeserver($uname,$udomain);
3306: my %newstorehash;
1.800 albertel 3307: foreach my $item (keys(%$storehash)) {
3308: my $key = $version.':'.&escape($symb).':'.$item;
3309: $newstorehash{$key} = $storehash->{$item};
1.716 albertel 3310: }
3311: my $items='';
3312: my %allitems = ();
1.800 albertel 3313: foreach my $item (keys(%newstorehash)) {
3314: if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
1.716 albertel 3315: my $key = $1.':keys:'.$2;
3316: $allitems{$key} .= $3.':';
3317: }
1.800 albertel 3318: $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
1.716 albertel 3319: }
1.800 albertel 3320: foreach my $item (keys(%allitems)) {
3321: $allitems{$item} =~ s/\:$//;
3322: $items.= $item.'='.$allitems{$item}.'&';
1.716 albertel 3323: }
3324: $items=~s/\&$//;
3325: return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.524 raeburn 3326: }
3327:
1.47 www 3328: # ------------------------------------------------------ critical put interface
3329:
3330: sub cput {
1.134 albertel 3331: my ($namespace,$storehash,$udomain,$uname)=@_;
1.620 albertel 3332: if (!$udomain) { $udomain=$env{'user.domain'}; }
3333: if (!$uname) { $uname=$env{'user.name'}; }
1.134 albertel 3334: my $uhome=&homeserver($uname,$udomain);
1.47 www 3335: my $items='';
1.800 albertel 3336: foreach my $item (keys(%$storehash)) {
3337: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.191 harris41 3338: }
1.47 www 3339: $items=~s/\&$//;
1.134 albertel 3340: return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
1.12 www 3341: }
3342:
3343: # -------------------------------------------------------------- eget interface
3344:
3345: sub eget {
1.133 albertel 3346: my ($namespace,$storearr,$udomain,$uname)=@_;
1.12 www 3347: my $items='';
1.800 albertel 3348: foreach my $item (@$storearr) {
3349: $items.=&escape($item).'&';
1.191 harris41 3350: }
1.12 www 3351: $items=~s/\&$//;
1.620 albertel 3352: if (!$udomain) { $udomain=$env{'user.domain'}; }
3353: if (!$uname) { $uname=$env{'user.name'}; }
1.133 albertel 3354: my $uhome=&homeserver($uname,$udomain);
3355: my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
1.12 www 3356: my @pairs=split(/\&/,$rep);
3357: my %returnhash=();
1.42 www 3358: my $i=0;
1.800 albertel 3359: foreach my $item (@$storearr) {
3360: $returnhash{$item}=&thaw_unescape($pairs[$i]);
1.42 www 3361: $i++;
1.191 harris41 3362: }
1.12 www 3363: return %returnhash;
3364: }
3365:
1.667 albertel 3366: # ------------------------------------------------------------ tmpput interface
3367: sub tmpput {
1.802 raeburn 3368: my ($storehash,$server,$context)=@_;
1.667 albertel 3369: my $items='';
1.800 albertel 3370: foreach my $item (keys(%$storehash)) {
3371: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.667 albertel 3372: }
3373: $items=~s/\&$//;
1.802 raeburn 3374: if (defined($context)) {
3375: $items .= ':'.&escape($context);
3376: }
1.667 albertel 3377: return &reply("tmpput:$items",$server);
3378: }
3379:
3380: # ------------------------------------------------------------ tmpget interface
3381: sub tmpget {
1.688 albertel 3382: my ($token,$server)=@_;
3383: if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
3384: my $rep=&reply("tmpget:$token",$server);
1.667 albertel 3385: my %returnhash;
3386: foreach my $item (split(/\&/,$rep)) {
3387: my ($key,$value)=split(/=/,$item);
3388: $returnhash{&unescape($key)}=&thaw_unescape($value);
3389: }
3390: return %returnhash;
3391: }
3392:
1.688 albertel 3393: # ------------------------------------------------------------ tmpget interface
3394: sub tmpdel {
3395: my ($token,$server)=@_;
3396: if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
3397: return &reply("tmpdel:$token",$server);
3398: }
3399:
1.765 albertel 3400: # -------------------------------------------------- portfolio access checking
3401:
3402: sub portfolio_access {
1.766 albertel 3403: my ($requrl) = @_;
1.765 albertel 3404: my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
3405: my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
1.814 raeburn 3406: if ($result) {
3407: my %setters;
3408: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
3409: my ($startblock,$endblock) =
3410: &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
3411: if ($startblock && $endblock) {
3412: return 'B';
3413: }
3414: } else {
3415: my ($startblock,$endblock) =
3416: &Apache::loncommon::blockcheck(\%setters,'port');
3417: if ($startblock && $endblock) {
3418: return 'B';
3419: }
3420: }
3421: }
1.765 albertel 3422: if ($result eq 'ok') {
1.766 albertel 3423: return 'F';
1.765 albertel 3424: } elsif ($result =~ /^[^:]+:guest_/) {
1.766 albertel 3425: return 'A';
1.765 albertel 3426: }
1.766 albertel 3427: return '';
1.765 albertel 3428: }
3429:
3430: sub get_portfolio_access {
1.767 albertel 3431: my ($udom,$unum,$file_name,$group,$access_hash) = @_;
3432:
3433: if (!ref($access_hash)) {
3434: my $current_perms = &get_portfile_permissions($udom,$unum);
3435: my %access_controls = &get_access_controls($current_perms,$group,
3436: $file_name);
3437: $access_hash = $access_controls{$file_name};
3438: }
3439:
1.765 albertel 3440: my ($public,$guest,@domains,@users,@courses,@groups);
3441: my $now = time;
3442: if (ref($access_hash) eq 'HASH') {
3443: foreach my $key (keys(%{$access_hash})) {
3444: my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
3445: if ($start > $now) {
3446: next;
3447: }
3448: if ($end && $end<$now) {
3449: next;
3450: }
3451: if ($scope eq 'public') {
3452: $public = $key;
3453: last;
3454: } elsif ($scope eq 'guest') {
3455: $guest = $key;
3456: } elsif ($scope eq 'domains') {
3457: push(@domains,$key);
3458: } elsif ($scope eq 'users') {
3459: push(@users,$key);
3460: } elsif ($scope eq 'course') {
3461: push(@courses,$key);
3462: } elsif ($scope eq 'group') {
3463: push(@groups,$key);
3464: }
3465: }
3466: if ($public) {
3467: return 'ok';
3468: }
3469: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
3470: if ($guest) {
3471: return $guest;
3472: }
3473: } else {
3474: if (@domains > 0) {
3475: foreach my $domkey (@domains) {
3476: if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
3477: if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
3478: return 'ok';
3479: }
3480: }
3481: }
3482: }
3483: if (@users > 0) {
3484: foreach my $userkey (@users) {
3485: if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
3486: return 'ok';
3487: }
3488: }
3489: }
3490: my %roleshash;
3491: my @courses_and_groups = @courses;
3492: push(@courses_and_groups,@groups);
3493: if (@courses_and_groups > 0) {
3494: my (%allgroups,%allroles);
3495: my ($start,$end,$role,$sec,$group);
3496: foreach my $envkey (%env) {
1.811 albertel 3497: if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
1.765 albertel 3498: my $cid = $2.'_'.$3;
3499: if ($1 eq 'gr') {
3500: $group = $4;
3501: $allgroups{$cid}{$group} = $env{$envkey};
3502: } else {
3503: if ($4 eq '') {
3504: $sec = 'none';
3505: } else {
3506: $sec = $4;
3507: }
3508: $allroles{$cid}{$1}{$sec} = $env{$envkey};
3509: }
1.811 albertel 3510: } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
1.765 albertel 3511: my $cid = $2.'_'.$3;
3512: if ($4 eq '') {
3513: $sec = 'none';
3514: } else {
3515: $sec = $4;
3516: }
3517: $allroles{$cid}{$1}{$sec} = $env{$envkey};
3518: }
3519: }
3520: if (keys(%allroles) == 0) {
3521: return;
3522: }
3523: foreach my $key (@courses_and_groups) {
3524: my %content = %{$$access_hash{$key}};
3525: my $cnum = $content{'number'};
3526: my $cdom = $content{'domain'};
3527: my $cid = $cdom.'_'.$cnum;
3528: if (!exists($allroles{$cid})) {
3529: next;
3530: }
3531: foreach my $role_id (keys(%{$content{'roles'}})) {
3532: my @sections = @{$content{'roles'}{$role_id}{'section'}};
3533: my @groups = @{$content{'roles'}{$role_id}{'group'}};
3534: my @status = @{$content{'roles'}{$role_id}{'access'}};
3535: my @roles = @{$content{'roles'}{$role_id}{'role'}};
3536: foreach my $role (keys(%{$allroles{$cid}})) {
3537: if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
3538: foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
3539: if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
3540: if (grep/^all$/,@sections) {
3541: return 'ok';
3542: } else {
3543: if (grep/^$sec$/,@sections) {
3544: return 'ok';
3545: }
3546: }
3547: }
3548: }
3549: if (keys(%{$allgroups{$cid}}) == 0) {
3550: if (grep/^none$/,@groups) {
3551: return 'ok';
3552: }
3553: } else {
3554: if (grep/^all$/,@groups) {
3555: return 'ok';
3556: }
3557: foreach my $group (keys(%{$allgroups{$cid}})) {
3558: if (grep/^$group$/,@groups) {
3559: return 'ok';
3560: }
3561: }
3562: }
3563: }
3564: }
3565: }
3566: }
3567: }
3568: if ($guest) {
3569: return $guest;
3570: }
3571: }
3572: }
3573: return;
3574: }
3575:
3576: sub course_group_datechecker {
3577: my ($dates,$now,$status) = @_;
3578: my ($start,$end) = split(/\./,$dates);
3579: if (!$start && !$end) {
3580: return 'ok';
3581: }
3582: if (grep/^active$/,@{$status}) {
3583: if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
3584: return 'ok';
3585: }
3586: }
3587: if (grep/^previous$/,@{$status}) {
3588: if ($end > $now ) {
3589: return 'ok';
3590: }
3591: }
3592: if (grep/^future$/,@{$status}) {
3593: if ($start > $now) {
3594: return 'ok';
3595: }
3596: }
3597: return;
3598: }
3599:
3600: sub parse_portfolio_url {
3601: my ($url) = @_;
3602:
3603: my ($type,$udom,$unum,$group,$file_name);
3604:
1.823 albertel 3605: if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
1.765 albertel 3606: $type = 1;
3607: $udom = $1;
3608: $unum = $2;
3609: $file_name = $3;
1.823 albertel 3610: } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
1.765 albertel 3611: $type = 2;
3612: $udom = $1;
3613: $unum = $2;
3614: $group = $3;
3615: $file_name = $3.'/'.$4;
3616: }
3617: if (wantarray) {
3618: return ($type,$udom,$unum,$file_name,$group);
3619: }
3620: return $type;
3621: }
3622:
3623: sub is_portfolio_url {
3624: my ($url) = @_;
3625: return scalar(&parse_portfolio_url($url));
3626: }
3627:
1.798 raeburn 3628: sub is_portfolio_file {
3629: my ($file) = @_;
1.820 raeburn 3630: if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
1.798 raeburn 3631: return 1;
3632: }
3633: return;
3634: }
3635:
3636:
1.341 www 3637: # ---------------------------------------------- Custom access rule evaluation
3638:
3639: sub customaccess {
3640: my ($priv,$uri)=@_;
1.807 albertel 3641: my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
1.819 www 3642: my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
1.807 albertel 3643: $udom = &LONCAPA::clean_domain($udom);
3644: $ucrs = &LONCAPA::clean_username($ucrs);
1.341 www 3645: my $access=0;
1.800 albertel 3646: foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
3647: my ($effect,$realm,$role)=split(/\:/,$right);
1.343 www 3648: if ($role) {
3649: if ($role ne $urole) { next; }
3650: }
1.800 albertel 3651: foreach my $scope (split(/\s*\,\s*/,$realm)) {
3652: my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
1.343 www 3653: if ($tdom) {
3654: if ($tdom ne $udom) { next; }
3655: }
3656: if ($tcrs) {
3657: if ($tcrs ne $ucrs) { next; }
3658: }
3659: if ($tsec) {
3660: if ($tsec ne $usec) { next; }
3661: }
3662: $access=($effect eq 'allow');
3663: last;
1.342 www 3664: }
1.402 bowersj2 3665: if ($realm eq '' && $role eq '') {
3666: $access=($effect eq 'allow');
3667: }
1.341 www 3668: }
3669: return $access;
3670: }
3671:
1.103 harris41 3672: # ------------------------------------------------- Check for a user privilege
1.12 www 3673:
3674: sub allowed {
1.810 raeburn 3675: my ($priv,$uri,$symb,$role)=@_;
1.705 albertel 3676: my $ver_orguri=$uri;
1.439 www 3677: $uri=&deversion($uri);
1.152 www 3678: my $orguri=$uri;
1.52 www 3679: $uri=&declutter($uri);
1.809 raeburn 3680:
1.810 raeburn 3681: if ($priv eq 'evb') {
3682: # Evade communication block restrictions for specified role in a course
3683: if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
3684: return $1;
3685: } else {
3686: return;
3687: }
3688: }
3689:
1.620 albertel 3690: if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
1.54 www 3691: # Free bre access to adm and meta resources
1.775 albertel 3692: if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
1.769 albertel 3693: || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
3694: && ($priv eq 'bre')) {
1.14 www 3695: return 'F';
1.159 www 3696: }
3697:
1.545 banghart 3698: # Free bre access to user's own portfolio contents
1.714 raeburn 3699: my ($space,$domain,$name,@dir)=split('/',$uri);
1.647 raeburn 3700: if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
1.714 raeburn 3701: ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
1.814 raeburn 3702: my %setters;
3703: my ($startblock,$endblock) =
3704: &Apache::loncommon::blockcheck(\%setters,'port');
3705: if ($startblock && $endblock) {
3706: return 'B';
3707: } else {
3708: return 'F';
3709: }
1.545 banghart 3710: }
3711:
1.762 raeburn 3712: # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
1.714 raeburn 3713: if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups')
3714: && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
3715: if (exists($env{'request.course.id'})) {
3716: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
3717: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
3718: if (($domain eq $cdom) && ($name eq $cnum)) {
3719: my $courseprivid=$env{'request.course.id'};
3720: $courseprivid=~s/\_/\//;
3721: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
3722: .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
3723: return $1;
1.762 raeburn 3724: } else {
3725: if ($env{'request.course.sec'}) {
3726: $courseprivid.='/'.$env{'request.course.sec'};
3727: }
3728: if ($env{'user.priv.'.$env{'request.role'}.'./'.
3729: $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
3730: return $2;
3731: }
1.714 raeburn 3732: }
3733: }
3734: }
3735: }
3736:
1.159 www 3737: # Free bre to public access
3738:
3739: if ($priv eq 'bre') {
1.238 www 3740: my $copyright=&metadata($uri,'copyright');
1.620 albertel 3741: if (($copyright eq 'public') && (!$env{'request.course.id'})) {
1.301 www 3742: return 'F';
3743: }
1.238 www 3744: if ($copyright eq 'priv') {
3745: $uri=~/([^\/]+)\/([^\/]+)\//;
1.620 albertel 3746: unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) {
1.238 www 3747: return '';
3748: }
3749: }
3750: if ($copyright eq 'domain') {
3751: $uri=~/([^\/]+)\/([^\/]+)\//;
1.620 albertel 3752: unless (($env{'user.domain'} eq $1) ||
3753: ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) {
1.238 www 3754: return '';
3755: }
1.262 matthew 3756: }
1.620 albertel 3757: if ($env{'request.role'}=~ /li\.\//) {
1.262 matthew 3758: # Library role, so allow browsing of resources in this domain.
3759: return 'F';
1.238 www 3760: }
1.341 www 3761: if ($copyright eq 'custom') {
3762: unless (&customaccess($priv,$uri)) { return ''; }
3763: }
1.14 www 3764: }
1.264 matthew 3765: # Domain coordinator is trying to create a course
1.620 albertel 3766: if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
1.264 matthew 3767: # uri is the requested domain in this case.
3768: # comparison to 'request.role.domain' shows if the user has selected
1.678 raeburn 3769: # a role of dc for the domain in question.
1.620 albertel 3770: return 'F' if ($uri eq $env{'request.role.domain'});
1.264 matthew 3771: }
1.29 www 3772:
1.52 www 3773: my $thisallowed='';
3774: my $statecond=0;
3775: my $courseprivid='';
3776:
3777: # Course
3778:
1.620 albertel 3779: if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
1.52 www 3780: $thisallowed.=$1;
3781: }
1.29 www 3782:
1.52 www 3783: # Domain
3784:
1.620 albertel 3785: if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
1.479 albertel 3786: =~/\Q$priv\E\&([^\:]*)/) {
1.12 www 3787: $thisallowed.=$1;
3788: }
1.52 www 3789:
3790: # Course: uri itself is a course
1.66 www 3791: my $courseuri=$uri;
3792: $courseuri=~s/\_(\d)/\/$1/;
1.83 www 3793: $courseuri=~s/^([^\/])/\/$1/;
1.81 www 3794:
1.620 albertel 3795: if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
1.479 albertel 3796: =~/\Q$priv\E\&([^\:]*)/) {
1.12 www 3797: $thisallowed.=$1;
3798: }
1.29 www 3799:
1.665 albertel 3800: # URI is an uploaded document for this course, default permissions don't matter
1.611 albertel 3801: # not allowing 'edit' access (editupload) to uploaded course docs
1.492 albertel 3802: if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
1.665 albertel 3803: $thisallowed='';
1.671 raeburn 3804: my ($match)=&is_on_map($uri);
3805: if ($match) {
3806: if ($env{'user.priv.'.$env{'request.role'}.'./'}
3807: =~/\Q$priv\E\&([^\:]*)/) {
3808: $thisallowed.=$1;
3809: }
3810: } else {
1.705 albertel 3811: my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
1.671 raeburn 3812: if ($refuri) {
3813: if ($refuri =~ m|^/adm/|) {
1.669 raeburn 3814: $thisallowed='F';
1.671 raeburn 3815: } else {
3816: $refuri=&declutter($refuri);
3817: my ($match) = &is_on_map($refuri);
3818: if ($match) {
3819: $thisallowed='F';
3820: }
1.669 raeburn 3821: }
1.671 raeburn 3822: }
3823: }
1.314 www 3824: }
1.492 albertel 3825:
1.766 albertel 3826: if ($priv eq 'bre'
3827: && $thisallowed ne 'F'
3828: && $thisallowed ne '2'
3829: && &is_portfolio_url($uri)) {
3830: $thisallowed = &portfolio_access($uri);
3831: }
3832:
1.52 www 3833: # Full access at system, domain or course-wide level? Exit.
1.29 www 3834:
3835: if ($thisallowed=~/F/) {
3836: return 'F';
3837: }
3838:
1.52 www 3839: # If this is generating or modifying users, exit with special codes
1.29 www 3840:
1.643 www 3841: if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
3842: if (($priv eq 'cca') || ($priv eq 'caa')) {
1.642 albertel 3843: my ($audom,$auname)=split('/',$uri);
1.643 www 3844: # no author name given, so this just checks on the general right to make a co-author in this domain
3845: unless ($auname) { return $thisallowed; }
3846: # an author name is given, so we are about to actually make a co-author for a certain account
1.642 albertel 3847: if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
3848: (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
3849: ($audom ne $env{'request.role.domain'}))) { return ''; }
3850: }
1.52 www 3851: return $thisallowed;
3852: }
3853: #
1.103 harris41 3854: # Gathered so far: system, domain and course wide privileges
1.52 www 3855: #
3856: # Course: See if uri or referer is an individual resource that is part of
3857: # the course
3858:
1.620 albertel 3859: if ($env{'request.course.id'}) {
1.232 www 3860:
1.620 albertel 3861: $courseprivid=$env{'request.course.id'};
3862: if ($env{'request.course.sec'}) {
3863: $courseprivid.='/'.$env{'request.course.sec'};
1.52 www 3864: }
3865: $courseprivid=~s/\_/\//;
3866: my $checkreferer=1;
1.232 www 3867: my ($match,$cond)=&is_on_map($uri);
3868: if ($match) {
3869: $statecond=$cond;
1.620 albertel 3870: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
1.479 albertel 3871: =~/\Q$priv\E\&([^\:]*)/) {
1.52 www 3872: $thisallowed.=$1;
3873: $checkreferer=0;
3874: }
1.29 www 3875: }
1.83 www 3876:
1.148 www 3877: if ($checkreferer) {
1.620 albertel 3878: my $refuri=$env{'httpref.'.$orguri};
1.148 www 3879: unless ($refuri) {
1.800 albertel 3880: foreach my $key (keys(%env)) {
3881: if ($key=~/^httpref\..*\*/) {
3882: my $pattern=$key;
1.156 www 3883: $pattern=~s/^httpref\.\/res\///;
1.148 www 3884: $pattern=~s/\*/\[\^\/\]\+/g;
3885: $pattern=~s/\//\\\//g;
1.152 www 3886: if ($orguri=~/$pattern/) {
1.800 albertel 3887: $refuri=$env{$key};
1.148 www 3888: }
3889: }
1.191 harris41 3890: }
1.148 www 3891: }
1.232 www 3892:
1.148 www 3893: if ($refuri) {
1.152 www 3894: $refuri=&declutter($refuri);
1.232 www 3895: my ($match,$cond)=&is_on_map($refuri);
3896: if ($match) {
3897: my $refstatecond=$cond;
1.620 albertel 3898: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
1.479 albertel 3899: =~/\Q$priv\E\&([^\:]*)/) {
1.52 www 3900: $thisallowed.=$1;
1.53 www 3901: $uri=$refuri;
3902: $statecond=$refstatecond;
1.52 www 3903: }
3904: }
1.148 www 3905: }
1.29 www 3906: }
1.52 www 3907: }
1.29 www 3908:
1.52 www 3909: #
1.103 harris41 3910: # Gathered now: all privileges that could apply, and condition number
1.52 www 3911: #
3912: #
3913: # Full or no access?
3914: #
1.29 www 3915:
1.52 www 3916: if ($thisallowed=~/F/) {
3917: return 'F';
3918: }
1.29 www 3919:
1.52 www 3920: unless ($thisallowed) {
3921: return '';
3922: }
1.29 www 3923:
1.52 www 3924: # Restrictions exist, deal with them
3925: #
3926: # C:according to course preferences
3927: # R:according to resource settings
3928: # L:unless locked
3929: # X:according to user session state
3930: #
3931:
3932: # Possibly locked functionality, check all courses
1.54 www 3933: # Locks might take effect only after 10 minutes cache expiration for other
3934: # courses, and 2 minutes for current course
1.52 www 3935:
3936: my $envkey;
3937: if ($thisallowed=~/L/) {
1.620 albertel 3938: foreach $envkey (keys %env) {
1.54 www 3939: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
3940: my $courseid=$2;
3941: my $roleid=$1.'.'.$2;
1.92 www 3942: $courseid=~s/^\///;
1.54 www 3943: my $expiretime=600;
1.620 albertel 3944: if ($env{'request.role'} eq $roleid) {
1.54 www 3945: $expiretime=120;
3946: }
3947: my ($cdom,$cnum,$csec)=split(/\//,$courseid);
3948: my $prefix='course.'.$cdom.'_'.$cnum.'.';
1.620 albertel 3949: if ((time-$env{$prefix.'last_cache'})>$expiretime) {
1.731 albertel 3950: &coursedescription($courseid,{'freshen_cache' => 1});
1.54 www 3951: }
1.620 albertel 3952: if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
3953: || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
3954: if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) {
3955: &log($env{'user.domain'},$env{'user.name'},
3956: $env{'user.home'},
1.57 www 3957: 'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52 www 3958: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.620 albertel 3959: $env{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 3960: return '';
3961: }
3962: }
1.620 albertel 3963: if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
3964: || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
3965: if ($env{'priv.'.$priv.'.lock.expire'}>time) {
3966: &log($env{'user.domain'},$env{'user.name'},
3967: $env{'user.home'},
1.57 www 3968: 'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52 www 3969: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.620 albertel 3970: $env{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 3971: return '';
3972: }
3973: }
3974: }
1.29 www 3975: }
1.52 www 3976: }
3977:
3978: #
3979: # Rest of the restrictions depend on selected course
3980: #
3981:
1.620 albertel 3982: unless ($env{'request.course.id'}) {
1.766 albertel 3983: if ($thisallowed eq 'A') {
3984: return 'A';
1.814 raeburn 3985: } elsif ($thisallowed eq 'B') {
3986: return 'B';
1.766 albertel 3987: } else {
3988: return '1';
3989: }
1.52 www 3990: }
1.29 www 3991:
1.52 www 3992: #
3993: # Now user is definitely in a course
3994: #
1.53 www 3995:
3996:
3997: # Course preferences
3998:
3999: if ($thisallowed=~/C/) {
1.620 albertel 4000: my $rolecode=(split(/\./,$env{'request.role'}))[0];
4001: my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
4002: if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
1.479 albertel 4003: =~/\Q$rolecode\E/) {
1.689 albertel 4004: if ($priv ne 'pch') {
4005: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
4006: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
4007: $env{'request.course.id'});
4008: }
1.237 www 4009: return '';
4010: }
4011:
1.620 albertel 4012: if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
1.479 albertel 4013: =~/\Q$unamedom\E/) {
1.689 albertel 4014: if ($priv ne 'pch') {
4015: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
4016: 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
4017: $env{'request.course.id'});
4018: }
1.54 www 4019: return '';
4020: }
1.53 www 4021: }
4022:
4023: # Resource preferences
4024:
4025: if ($thisallowed=~/R/) {
1.620 albertel 4026: my $rolecode=(split(/\./,$env{'request.role'}))[0];
1.479 albertel 4027: if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
1.689 albertel 4028: if ($priv ne 'pch') {
4029: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
4030: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
4031: }
4032: return '';
1.54 www 4033: }
1.53 www 4034: }
1.30 www 4035:
1.246 www 4036: # Restricted by state or randomout?
1.30 www 4037:
1.52 www 4038: if ($thisallowed=~/X/) {
1.620 albertel 4039: if ($env{'acc.randomout'}) {
1.579 albertel 4040: if (!$symb) { $symb=&symbread($uri,1); }
1.620 albertel 4041: if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) {
1.248 www 4042: return '';
4043: }
1.247 www 4044: }
4045: if (&condval($statecond)) {
1.52 www 4046: return '2';
4047: } else {
4048: return '';
4049: }
4050: }
1.30 www 4051:
1.766 albertel 4052: if ($thisallowed eq 'A') {
4053: return 'A';
1.814 raeburn 4054: } elsif ($thisallowed eq 'B') {
4055: return 'B';
1.766 albertel 4056: }
1.52 www 4057: return 'F';
1.232 www 4058: }
4059:
1.710 albertel 4060: sub split_uri_for_cond {
4061: my $uri=&deversion(&declutter(shift));
4062: my @uriparts=split(/\//,$uri);
4063: my $filename=pop(@uriparts);
4064: my $pathname=join('/',@uriparts);
4065: return ($pathname,$filename);
4066: }
1.232 www 4067: # --------------------------------------------------- Is a resource on the map?
4068:
4069: sub is_on_map {
1.710 albertel 4070: my ($pathname,$filename) = &split_uri_for_cond(shift);
1.289 bowersj2 4071: #Trying to find the conditional for the file
1.620 albertel 4072: my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
1.289 bowersj2 4073: /\&\Q$filename\E\:([\d\|]+)\&/);
1.232 www 4074: if ($match) {
1.289 bowersj2 4075: return (1,$1);
4076: } else {
1.434 www 4077: return (0,0);
1.289 bowersj2 4078: }
1.12 www 4079: }
4080:
1.427 www 4081: # --------------------------------------------------------- Get symb from alias
4082:
4083: sub get_symb_from_alias {
4084: my $symb=shift;
4085: my ($map,$resid,$url)=&decode_symb($symb);
4086: # Already is a symb
4087: if ($url) { return $symb; }
4088: # Must be an alias
4089: my $aliassymb='';
4090: my %bighash;
1.620 albertel 4091: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.427 www 4092: &GDBM_READER(),0640)) {
4093: my $rid=$bighash{'mapalias_'.$symb};
4094: if ($rid) {
4095: my ($mapid,$resid)=split(/\./,$rid);
1.429 albertel 4096: $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
4097: $resid,$bighash{'src_'.$rid});
1.427 www 4098: }
4099: untie %bighash;
4100: }
4101: return $aliassymb;
4102: }
4103:
1.12 www 4104: # ----------------------------------------------------------------- Define Role
4105:
4106: sub definerole {
4107: if (allowed('mcr','/')) {
4108: my ($rolename,$sysrole,$domrole,$courole)=@_;
1.800 albertel 4109: foreach my $role (split(':',$sysrole)) {
4110: my ($crole,$cqual)=split(/\&/,$role);
1.479 albertel 4111: if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
4112: if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
4113: if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
1.21 www 4114: return "refused:s:$crole&$cqual";
4115: }
4116: }
1.191 harris41 4117: }
1.800 albertel 4118: foreach my $role (split(':',$domrole)) {
4119: my ($crole,$cqual)=split(/\&/,$role);
1.479 albertel 4120: if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
4121: if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
4122: if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
1.21 www 4123: return "refused:d:$crole&$cqual";
4124: }
4125: }
1.191 harris41 4126: }
1.800 albertel 4127: foreach my $role (split(':',$courole)) {
4128: my ($crole,$cqual)=split(/\&/,$role);
1.479 albertel 4129: if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
4130: if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
4131: if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
1.21 www 4132: return "refused:c:$crole&$cqual";
4133: }
4134: }
1.191 harris41 4135: }
1.620 albertel 4136: my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
4137: "$env{'user.domain'}:$env{'user.name'}:".
1.21 www 4138: "rolesdef_$rolename=".
4139: escape($sysrole.'_'.$domrole.'_'.$courole);
1.620 albertel 4140: return reply($command,$env{'user.home'});
1.12 www 4141: } else {
4142: return 'refused';
4143: }
1.105 harris41 4144: }
4145:
4146: # ---------------- Make a metadata query against the network of library servers
4147:
4148: sub metadata_query {
1.244 matthew 4149: my ($query,$custom,$customshow,$server_array)=@_;
1.120 harris41 4150: my %rhash;
1.244 matthew 4151: my @server_list = (defined($server_array) ? @$server_array
4152: : keys(%libserv) );
4153: for my $server (@server_list) {
1.118 harris41 4154: unless ($custom or $customshow) {
4155: my $reply=&reply("querysend:".&escape($query),$server);
4156: $rhash{$server}=$reply;
4157: }
4158: else {
4159: my $reply=&reply("querysend:".&escape($query).':'.
4160: &escape($custom).':'.&escape($customshow),
4161: $server);
4162: $rhash{$server}=$reply;
4163: }
1.112 harris41 4164: }
1.118 harris41 4165: return \%rhash;
1.240 www 4166: }
4167:
4168: # ----------------------------------------- Send log queries and wait for reply
4169:
4170: sub log_query {
4171: my ($uname,$udom,$query,%filters)=@_;
4172: my $uhome=&homeserver($uname,$udom);
4173: if ($uhome eq 'no_host') { return 'error: no_host'; }
4174: my $uhost=$hostname{$uhome};
1.800 albertel 4175: my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
1.240 www 4176: my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
4177: $uhome);
1.479 albertel 4178: unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
1.242 www 4179: return get_query_reply($queryid);
4180: }
4181:
1.818 raeburn 4182: # -------------------------- Update MySQL table for portfolio file
4183:
4184: sub update_portfolio_table {
1.821 raeburn 4185: my ($uname,$udom,$file_name,$query,$group,$action) = @_;
1.818 raeburn 4186: my $homeserver = &homeserver($uname,$udom);
4187: my $queryid=
1.821 raeburn 4188: &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
4189: ':'.&escape($file_name).':'.$action,$homeserver);
1.818 raeburn 4190: my $reply = &get_query_reply($queryid);
4191: return $reply;
4192: }
4193:
1.508 raeburn 4194: # ------- Request retrieval of institutional classlists for course(s)
1.506 raeburn 4195:
4196: sub fetch_enrollment_query {
1.511 raeburn 4197: my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
1.508 raeburn 4198: my $homeserver;
1.547 raeburn 4199: my $maxtries = 1;
1.508 raeburn 4200: if ($context eq 'automated') {
4201: $homeserver = $perlvar{'lonHostID'};
1.547 raeburn 4202: $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
1.508 raeburn 4203: } else {
4204: $homeserver = &homeserver($cnum,$dom);
4205: }
1.506 raeburn 4206: my $host=$hostname{$homeserver};
4207: my $cmd = '';
1.800 albertel 4208: foreach my $affiliate (keys %{$affiliatesref}) {
4209: $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
1.506 raeburn 4210: }
4211: $cmd =~ s/%%$//;
4212: $cmd = &escape($cmd);
4213: my $query = 'fetchenrollment';
1.620 albertel 4214: my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver);
1.526 raeburn 4215: unless ($queryid=~/^\Q$host\E\_/) {
4216: &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
4217: return 'error: '.$queryid;
4218: }
1.506 raeburn 4219: my $reply = &get_query_reply($queryid);
1.547 raeburn 4220: my $tries = 1;
4221: while (($reply=~/^timeout/) && ($tries < $maxtries)) {
4222: $reply = &get_query_reply($queryid);
4223: $tries ++;
4224: }
1.526 raeburn 4225: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
1.620 albertel 4226: &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
1.526 raeburn 4227: } else {
1.515 raeburn 4228: my @responses = split/:/,$reply;
4229: if ($homeserver eq $perlvar{'lonHostID'}) {
1.800 albertel 4230: foreach my $line (@responses) {
4231: my ($key,$value) = split(/=/,$line,2);
1.515 raeburn 4232: $$replyref{$key} = $value;
4233: }
4234: } else {
1.506 raeburn 4235: my $pathname = $perlvar{'lonDaemons'}.'/tmp';
1.800 albertel 4236: foreach my $line (@responses) {
4237: my ($key,$value) = split(/=/,$line);
1.506 raeburn 4238: $$replyref{$key} = $value;
4239: if ($value > 0) {
1.800 albertel 4240: foreach my $item (@{$$affiliatesref{$key}}) {
4241: my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
1.506 raeburn 4242: my $destname = $pathname.'/'.$filename;
4243: my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
1.526 raeburn 4244: if ($xml_classlist =~ /^error/) {
4245: &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
4246: } else {
1.506 raeburn 4247: if ( open(FILE,">$destname") ) {
4248: print FILE &unescape($xml_classlist);
4249: close(FILE);
1.526 raeburn 4250: } else {
4251: &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
1.506 raeburn 4252: }
4253: }
4254: }
4255: }
4256: }
4257: }
4258: return 'ok';
4259: }
4260: return 'error';
4261: }
4262:
1.242 www 4263: sub get_query_reply {
4264: my $queryid=shift;
1.240 www 4265: my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
4266: my $reply='';
4267: for (1..100) {
4268: sleep 2;
4269: if (-e $replyfile.'.end') {
1.448 albertel 4270: if (open(my $fh,$replyfile)) {
1.240 www 4271: $reply.=<$fh>;
1.448 albertel 4272: close($fh);
1.240 www 4273: } else { return 'error: reply_file_error'; }
1.242 www 4274: return &unescape($reply);
4275: }
1.240 www 4276: }
1.242 www 4277: return 'timeout:'.$queryid;
1.240 www 4278: }
4279:
4280: sub courselog_query {
1.241 www 4281: #
4282: # possible filters:
4283: # url: url or symb
4284: # username
4285: # domain
4286: # action: view, submit, grade
4287: # start: timestamp
4288: # end: timestamp
4289: #
1.240 www 4290: my (%filters)=@_;
1.620 albertel 4291: unless ($env{'request.course.id'}) { return 'no_course'; }
1.241 www 4292: if ($filters{'url'}) {
4293: $filters{'url'}=&symbclean(&declutter($filters{'url'}));
4294: $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
4295: $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
4296: }
1.620 albertel 4297: my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
4298: my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1.240 www 4299: return &log_query($cname,$cdom,'courselog',%filters);
4300: }
4301:
4302: sub userlog_query {
4303: my ($uname,$udom,%filters)=@_;
4304: return &log_query($uname,$udom,'userlog',%filters);
1.12 www 4305: }
4306:
1.506 raeburn 4307: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course
4308:
4309: sub auto_run {
1.508 raeburn 4310: my ($cnum,$cdom) = @_;
4311: my $homeserver = &homeserver($cnum,$cdom);
1.511 raeburn 4312: my $response = &reply('autorun:'.$cdom,$homeserver);
1.506 raeburn 4313: return $response;
4314: }
1.776 albertel 4315:
1.506 raeburn 4316: sub auto_get_sections {
1.508 raeburn 4317: my ($cnum,$cdom,$inst_coursecode) = @_;
4318: my $homeserver = &homeserver($cnum,$cdom);
1.506 raeburn 4319: my @secs = ();
1.511 raeburn 4320: my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
1.506 raeburn 4321: unless ($response eq 'refused') {
4322: @secs = split/:/,$response;
4323: }
4324: return @secs;
4325: }
1.776 albertel 4326:
1.506 raeburn 4327: sub auto_new_course {
1.508 raeburn 4328: my ($cnum,$cdom,$inst_course_id,$owner) = @_;
4329: my $homeserver = &homeserver($cnum,$cdom);
1.515 raeburn 4330: my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
1.506 raeburn 4331: return $response;
4332: }
1.776 albertel 4333:
1.506 raeburn 4334: sub auto_validate_courseID {
1.508 raeburn 4335: my ($cnum,$cdom,$inst_course_id) = @_;
4336: my $homeserver = &homeserver($cnum,$cdom);
1.511 raeburn 4337: my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
1.506 raeburn 4338: return $response;
4339: }
1.776 albertel 4340:
1.506 raeburn 4341: sub auto_create_password {
1.508 raeburn 4342: my ($cnum,$cdom,$authparam) = @_;
4343: my $homeserver = &homeserver($cnum,$cdom);
1.506 raeburn 4344: my $create_passwd = 0;
4345: my $authchk = '';
1.511 raeburn 4346: my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
1.506 raeburn 4347: if ($response eq 'refused') {
4348: $authchk = 'refused';
4349: } else {
4350: ($authparam,$create_passwd,$authchk) = split/:/,$response;
4351: }
4352: return ($authparam,$create_passwd,$authchk);
4353: }
4354:
1.706 raeburn 4355: sub auto_photo_permission {
4356: my ($cnum,$cdom,$students) = @_;
4357: my $homeserver = &homeserver($cnum,$cdom);
1.707 albertel 4358: my ($outcome,$perm_reqd,$conditions) =
4359: split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
1.709 albertel 4360: if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
4361: return (undef,undef);
4362: }
1.706 raeburn 4363: return ($outcome,$perm_reqd,$conditions);
4364: }
4365:
4366: sub auto_checkphotos {
4367: my ($uname,$udom,$pid) = @_;
4368: my $homeserver = &homeserver($uname,$udom);
4369: my ($result,$resulttype);
4370: my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
1.707 albertel 4371: &escape($uname).':'.&escape($pid),
4372: $homeserver));
1.709 albertel 4373: if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
4374: return (undef,undef);
4375: }
1.706 raeburn 4376: if ($outcome) {
4377: ($result,$resulttype) = split(/:/,$outcome);
4378: }
4379: return ($result,$resulttype);
4380: }
4381:
4382: sub auto_photochoice {
4383: my ($cnum,$cdom) = @_;
4384: my $homeserver = &homeserver($cnum,$cdom);
4385: my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
1.707 albertel 4386: &escape($cdom),
4387: $homeserver)));
1.709 albertel 4388: if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
4389: return (undef,undef);
4390: }
1.706 raeburn 4391: return ($update,$comment);
4392: }
4393:
4394: sub auto_photoupdate {
4395: my ($affiliatesref,$dom,$cnum,$photo) = @_;
4396: my $homeserver = &homeserver($cnum,$dom);
4397: my $host=$hostname{$homeserver};
4398: my $cmd = '';
4399: my $maxtries = 1;
1.800 albertel 4400: foreach my $affiliate (keys(%{$affiliatesref})) {
4401: $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
1.706 raeburn 4402: }
4403: $cmd =~ s/%%$//;
4404: $cmd = &escape($cmd);
4405: my $query = 'institutionalphotos';
4406: my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
4407: unless ($queryid=~/^\Q$host\E\_/) {
4408: &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
4409: return 'error: '.$queryid;
4410: }
4411: my $reply = &get_query_reply($queryid);
4412: my $tries = 1;
4413: while (($reply=~/^timeout/) && ($tries < $maxtries)) {
4414: $reply = &get_query_reply($queryid);
4415: $tries ++;
4416: }
4417: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
4418: &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
4419: } else {
4420: my @responses = split(/:/,$reply);
4421: my $outcome = shift(@responses);
4422: foreach my $item (@responses) {
4423: my ($key,$value) = split(/=/,$item);
4424: $$photo{$key} = $value;
4425: }
4426: return $outcome;
4427: }
4428: return 'error';
4429: }
4430:
1.521 raeburn 4431: sub auto_instcode_format {
1.793 albertel 4432: my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
4433: $cat_order) = @_;
1.521 raeburn 4434: my $courses = '';
1.772 raeburn 4435: my @homeservers;
1.521 raeburn 4436: if ($caller eq 'global') {
1.793 albertel 4437: foreach my $tryserver (keys(%libserv)) {
1.584 raeburn 4438: if ($hostdom{$tryserver} eq $codedom) {
1.793 albertel 4439: if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
1.772 raeburn 4440: push(@homeservers,$tryserver);
4441: }
1.584 raeburn 4442: }
4443: }
1.521 raeburn 4444: } else {
1.772 raeburn 4445: push(@homeservers,&homeserver($caller,$codedom));
1.521 raeburn 4446: }
1.793 albertel 4447: foreach my $code (keys(%{$instcodes})) {
4448: $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
1.521 raeburn 4449: }
4450: chop($courses);
1.772 raeburn 4451: my $ok_response = 0;
4452: my $response;
4453: while (@homeservers > 0 && $ok_response == 0) {
4454: my $server = shift(@homeservers);
4455: $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
4456: if ($response !~ /(con_lost|error|no_such_host|refused)/) {
4457: my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
1.793 albertel 4458: split/:/,$response;
1.772 raeburn 4459: %{$codes} = (%{$codes},&str2hash($codes_str));
4460: push(@{$codetitles},&str2array($codetitles_str));
4461: %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
4462: %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
4463: $ok_response = 1;
4464: }
4465: }
4466: if ($ok_response) {
1.521 raeburn 4467: return 'ok';
1.772 raeburn 4468: } else {
4469: return $response;
1.521 raeburn 4470: }
4471: }
4472:
1.792 raeburn 4473: sub auto_instcode_defaults {
4474: my ($domain,$returnhash,$code_order) = @_;
4475: my @homeservers;
1.793 albertel 4476: foreach my $tryserver (keys(%libserv)) {
1.792 raeburn 4477: if ($hostdom{$tryserver} eq $domain) {
1.793 albertel 4478: if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
1.792 raeburn 4479: push(@homeservers,$tryserver);
4480: }
4481: }
4482: }
4483: my $ok_response = 0;
4484: my $response;
4485: while (@homeservers > 0 && $ok_response == 0) {
4486: my $server = shift(@homeservers);
4487: $response=&reply('autoinstcodedefaults:'.$domain,$server);
4488: if ($response !~ /(con_lost|error|no_such_host|refused)/) {
1.793 albertel 4489: foreach my $pair (split(/\&/,$response)) {
4490: my ($name,$value)=split(/\=/,$pair);
1.792 raeburn 4491: if ($name eq 'code_order') {
1.796 raeburn 4492: @{$code_order} = split(/\&/,&unescape($value));
1.792 raeburn 4493: } else {
1.796 raeburn 4494: $returnhash->{&unescape($name)}=&unescape($value);
1.792 raeburn 4495: }
4496: }
1.804 raeburn 4497: $ok_response = 1;
1.792 raeburn 4498: }
4499: }
4500: if ($ok_response) {
4501: return 'ok';
4502: } else {
4503: return $response;
4504: }
4505: }
4506:
1.777 albertel 4507: sub auto_validate_class_sec {
1.773 raeburn 4508: my ($cdom,$cnum,$owner,$inst_class) = @_;
4509: my $homeserver = &homeserver($cnum,$cdom);
4510: my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
1.774 banghart 4511: &escape($owner).':'.$cdom,$homeserver);
1.773 raeburn 4512: return $response;
4513: }
4514:
1.679 raeburn 4515: # ------------------------------------------------------- Course Group routines
4516:
4517: sub get_coursegroups {
1.809 raeburn 4518: my ($cdom,$cnum,$group,$namespace) = @_;
4519: return(&dump($namespace,$cdom,$cnum,$group));
1.805 raeburn 4520: }
4521:
1.679 raeburn 4522: sub modify_coursegroup {
4523: my ($cdom,$cnum,$groupsettings) = @_;
4524: return(&put('coursegroups',$groupsettings,$cdom,$cnum));
4525: }
4526:
1.809 raeburn 4527: sub toggle_coursegroup_status {
4528: my ($cdom,$cnum,$group,$action) = @_;
4529: my ($from_namespace,$to_namespace);
4530: if ($action eq 'delete') {
4531: $from_namespace = 'coursegroups';
4532: $to_namespace = 'deleted_groups';
4533: } else {
4534: $from_namespace = 'deleted_groups';
4535: $to_namespace = 'coursegroups';
4536: }
4537: my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
1.805 raeburn 4538: if (my $tmp = &error(%curr_group)) {
4539: &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
4540: return ('read error',$tmp);
4541: } else {
4542: my %savedsettings = %curr_group;
1.809 raeburn 4543: my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
1.805 raeburn 4544: my $deloutcome;
4545: if ($result eq 'ok') {
1.809 raeburn 4546: $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
1.805 raeburn 4547: } else {
4548: return ('write error',$result);
4549: }
4550: if ($deloutcome eq 'ok') {
4551: return 'ok';
4552: } else {
4553: return ('delete error',$deloutcome);
4554: }
4555: }
4556: }
4557:
1.679 raeburn 4558: sub modify_group_roles {
4559: my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
4560: my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
4561: my $role = 'gr/'.&escape($userprivs);
4562: my ($uname,$udom) = split(/:/,$user);
4563: my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
1.684 raeburn 4564: if ($result eq 'ok') {
4565: &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
4566: }
1.679 raeburn 4567: return $result;
4568: }
4569:
4570: sub modify_coursegroup_membership {
4571: my ($cdom,$cnum,$membership) = @_;
4572: my $result = &put('groupmembership',$membership,$cdom,$cnum);
4573: return $result;
4574: }
4575:
1.682 raeburn 4576: sub get_active_groups {
4577: my ($udom,$uname,$cdom,$cnum) = @_;
4578: my $now = time;
4579: my %groups = ();
4580: foreach my $key (keys(%env)) {
1.811 albertel 4581: if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
1.682 raeburn 4582: my ($start,$end) = split(/\./,$env{$key});
4583: if (($end!=0) && ($end<$now)) { next; }
4584: if (($start!=0) && ($start>$now)) { next; }
4585: if ($1 eq $cdom && $2 eq $cnum) {
4586: $groups{$3} = $env{$key} ;
4587: }
4588: }
4589: }
4590: return %groups;
4591: }
4592:
1.683 raeburn 4593: sub get_group_membership {
4594: my ($cdom,$cnum,$group) = @_;
4595: return(&dump('groupmembership',$cdom,$cnum,$group));
4596: }
4597:
4598: sub get_users_groups {
4599: my ($udom,$uname,$courseid) = @_;
1.733 raeburn 4600: my @usersgroups;
1.683 raeburn 4601: my $cachetime=1800;
4602:
4603: my $hashid="$udom:$uname:$courseid";
1.733 raeburn 4604: my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
4605: if (defined($cached)) {
1.734 albertel 4606: @usersgroups = split(/:/,$grouplist);
1.733 raeburn 4607: } else {
4608: $grouplist = '';
1.816 raeburn 4609: my $courseurl = &courseid_to_courseurl($courseid);
4610: my %roleshash = &dump('roles',$udom,$uname,$courseurl);
1.817 raeburn 4611: my $access_end = $env{'course.'.$courseid.
4612: '.default_enrollment_end_date'};
4613: my $now = time;
4614: foreach my $key (keys(%roleshash)) {
4615: if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
4616: my $group = $1;
4617: if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
4618: my $start = $2;
4619: my $end = $1;
4620: if ($start == -1) { next; } # deleted from group
4621: if (($start!=0) && ($start>$now)) { next; }
4622: if (($end!=0) && ($end<$now)) {
4623: if ($access_end && $access_end < $now) {
4624: if ($access_end - $end < 86400) {
4625: push(@usersgroups,$group);
1.733 raeburn 4626: }
4627: }
1.817 raeburn 4628: next;
1.733 raeburn 4629: }
1.817 raeburn 4630: push(@usersgroups,$group);
1.683 raeburn 4631: }
4632: }
4633: }
1.817 raeburn 4634: @usersgroups = &sort_course_groups($courseid,@usersgroups);
4635: $grouplist = join(':',@usersgroups);
4636: &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
1.683 raeburn 4637: }
1.733 raeburn 4638: return @usersgroups;
1.683 raeburn 4639: }
4640:
4641: sub devalidate_getgroups_cache {
4642: my ($udom,$uname,$cdom,$cnum)=@_;
4643: my $courseid = $cdom.'_'.$cnum;
1.807 albertel 4644:
1.683 raeburn 4645: my $hashid="$udom:$uname:$courseid";
4646: &devalidate_cache_new('getgroups',$hashid);
4647: }
4648:
1.12 www 4649: # ------------------------------------------------------------------ Plain Text
4650:
4651: sub plaintext {
1.742 raeburn 4652: my ($short,$type,$cid) = @_;
1.758 albertel 4653: if ($short =~ /^cr/) {
4654: return (split('/',$short))[-1];
4655: }
1.742 raeburn 4656: if (!defined($cid)) {
4657: $cid = $env{'request.course.id'};
4658: }
4659: if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
4660: return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
4661: '.plaintext'});
4662: }
4663: my %rolenames = (
4664: Course => 'std',
4665: Group => 'alt1',
4666: );
4667: if (defined($type) &&
4668: defined($rolenames{$type}) &&
4669: defined($prp{$short}{$rolenames{$type}})) {
4670: return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
4671: } else {
4672: return &Apache::lonlocal::mt($prp{$short}{'std'});
4673: }
1.12 www 4674: }
4675:
4676: # ----------------------------------------------------------------- Assign Role
4677:
4678: sub assignrole {
1.357 www 4679: my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
1.21 www 4680: my $mrole;
4681: if ($role =~ /^cr\//) {
1.393 www 4682: my $cwosec=$url;
1.811 albertel 4683: $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
1.393 www 4684: unless (&allowed('ccr',$cwosec)) {
1.104 www 4685: &logthis('Refused custom assignrole: '.
4686: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1.620 albertel 4687: $env{'user.name'}.' at '.$env{'user.domain'});
1.104 www 4688: return 'refused';
4689: }
1.21 www 4690: $mrole='cr';
1.678 raeburn 4691: } elsif ($role =~ /^gr\//) {
4692: my $cwogrp=$url;
1.811 albertel 4693: $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
1.678 raeburn 4694: unless (&allowed('mdg',$cwogrp)) {
4695: &logthis('Refused group assignrole: '.
4696: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
4697: $env{'user.name'}.' at '.$env{'user.domain'});
4698: return 'refused';
4699: }
4700: $mrole='gr';
1.21 www 4701: } else {
1.82 www 4702: my $cwosec=$url;
1.811 albertel 4703: $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
1.373 www 4704: unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {
1.104 www 4705: &logthis('Refused assignrole: '.
4706: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1.620 albertel 4707: $env{'user.name'}.' at '.$env{'user.domain'});
1.104 www 4708: return 'refused';
4709: }
1.21 www 4710: $mrole=$role;
4711: }
1.620 albertel 4712: my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
1.21 www 4713: "$udom:$uname:$url".'_'."$mrole=$role";
1.81 www 4714: if ($end) { $command.='_'.$end; }
1.21 www 4715: if ($start) {
4716: if ($end) {
1.81 www 4717: $command.='_'.$start;
1.21 www 4718: } else {
1.81 www 4719: $command.='_0_'.$start;
1.21 www 4720: }
4721: }
1.739 raeburn 4722: my $origstart = $start;
4723: my $origend = $end;
1.357 www 4724: # actually delete
4725: if ($deleteflag) {
1.373 www 4726: if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
1.357 www 4727: # modify command to delete the role
1.620 albertel 4728: $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:".
1.357 www 4729: "$udom:$uname:$url".'_'."$mrole";
1.620 albertel 4730: &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom");
1.357 www 4731: # set start and finish to negative values for userrolelog
4732: $start=-1;
4733: $end=-1;
4734: }
4735: }
4736: # send command
1.349 www 4737: my $answer=&reply($command,&homeserver($uname,$udom));
1.357 www 4738: # log new user role if status is ok
1.349 www 4739: if ($answer eq 'ok') {
1.663 raeburn 4740: &userrolelog($role,$uname,$udom,$url,$start,$end);
1.739 raeburn 4741: # for course roles, perform group memberships changes triggered by role change.
4742: unless ($role =~ /^gr/) {
4743: &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
4744: $origstart);
4745: }
1.349 www 4746: }
4747: return $answer;
1.169 harris41 4748: }
4749:
4750: # -------------------------------------------------- Modify user authentication
1.197 www 4751: # Overrides without validation
4752:
1.169 harris41 4753: sub modifyuserauth {
4754: my ($udom,$uname,$umode,$upass)=@_;
4755: my $uhome=&homeserver($uname,$udom);
1.197 www 4756: unless (&allowed('mau',$udom)) { return 'refused'; }
4757: &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
1.620 albertel 4758: $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
4759: ' in domain '.$env{'request.role.domain'});
1.169 harris41 4760: my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
4761: &escape($upass),$uhome);
1.620 albertel 4762: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
1.197 www 4763: 'Authentication changed for '.$udom.', '.$uname.', '.$umode.
4764: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
4765: &log($udom,,$uname,$uhome,
1.620 albertel 4766: 'Authentication changed by '.$env{'user.domain'}.', '.
4767: $env{'user.name'}.', '.$umode.
1.197 www 4768: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
1.169 harris41 4769: unless ($reply eq 'ok') {
1.197 www 4770: &logthis('Authentication mode error: '.$reply);
1.169 harris41 4771: return 'error: '.$reply;
4772: }
1.170 harris41 4773: return 'ok';
1.80 www 4774: }
4775:
1.81 www 4776: # --------------------------------------------------------------- Modify a user
1.80 www 4777:
1.81 www 4778: sub modifyuser {
1.206 matthew 4779: my ($udom, $uname, $uid,
4780: $umode, $upass, $first,
4781: $middle, $last, $gene,
1.387 www 4782: $forceid, $desiredhome, $email)=@_;
1.807 albertel 4783: $udom= &LONCAPA::clean_domain($udom);
4784: $uname=&LONCAPA::clean_username($uname);
1.81 www 4785: &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
1.80 www 4786: $umode.', '.$first.', '.$middle.', '.
1.206 matthew 4787: $last.', '.$gene.'(forceid: '.$forceid.')'.
4788: (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
4789: ' desiredhome not specified').
1.620 albertel 4790: ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
4791: ' in domain '.$env{'request.role.domain'});
1.230 stredwic 4792: my $uhome=&homeserver($uname,$udom,'true');
1.80 www 4793: # ----------------------------------------------------------------- Create User
1.406 albertel 4794: if (($uhome eq 'no_host') &&
4795: (($umode && $upass) || ($umode eq 'localauth'))) {
1.80 www 4796: my $unhome='';
1.209 matthew 4797: if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
4798: $unhome = $desiredhome;
1.620 albertel 4799: } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
4800: $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
1.209 matthew 4801: } else { # load balancing routine for determining $unhome
1.80 www 4802: my $tryserver;
1.81 www 4803: my $loadm=10000000;
1.80 www 4804: foreach $tryserver (keys %libserv) {
4805: if ($hostdom{$tryserver} eq $udom) {
4806: my $answer=reply('load',$tryserver);
4807: if (($answer=~/\d+/) && ($answer<$loadm)) {
4808: $loadm=$answer;
4809: $unhome=$tryserver;
4810: }
4811: }
4812: }
4813: }
4814: if (($unhome eq '') || ($unhome eq 'no_host')) {
1.206 matthew 4815: return 'error: unable to find a home server for '.$uname.
4816: ' in domain '.$udom;
1.80 www 4817: }
4818: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
4819: &escape($upass),$unhome);
4820: unless ($reply eq 'ok') {
4821: return 'error: '.$reply;
4822: }
1.230 stredwic 4823: $uhome=&homeserver($uname,$udom,'true');
1.80 www 4824: if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
1.386 matthew 4825: return 'error: unable verify users home machine.';
1.80 www 4826: }
1.209 matthew 4827: } # End of creation of new user
1.80 www 4828: # ---------------------------------------------------------------------- Add ID
4829: if ($uid) {
4830: $uid=~tr/A-Z/a-z/;
4831: my %uidhash=&idrget($udom,$uname);
1.196 www 4832: if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)
4833: && (!$forceid)) {
1.80 www 4834: unless ($uid eq $uidhash{$uname}) {
1.386 matthew 4835: return 'error: user id "'.$uid.'" does not match '.
4836: 'current user id "'.$uidhash{$uname}.'".';
1.80 www 4837: }
4838: } else {
4839: &idput($udom,($uname => $uid));
4840: }
4841: }
4842: # -------------------------------------------------------------- Add names, etc
1.313 matthew 4843: my @tmp=&get('environment',
1.134 albertel 4844: ['firstname','middlename','lastname','generation'],
4845: $udom,$uname);
1.313 matthew 4846: my %names;
4847: if ($tmp[0] =~ m/^error:.*/) {
4848: %names=();
4849: } else {
4850: %names = @tmp;
4851: }
1.388 www 4852: #
4853: # Make sure to not trash student environment if instructor does not bother
4854: # to supply name and email information
4855: #
4856: if ($first) { $names{'firstname'} = $first; }
1.385 matthew 4857: if (defined($middle)) { $names{'middlename'} = $middle; }
1.388 www 4858: if ($last) { $names{'lastname'} = $last; }
1.385 matthew 4859: if (defined($gene)) { $names{'generation'} = $gene; }
1.592 www 4860: if ($email) {
4861: $email=~s/[^\w\@\.\-\,]//gs;
4862: if ($email=~/\@/) { $names{'notification'} = $email;
4863: $names{'critnotification'} = $email;
4864: $names{'permanentemail'} = $email; }
4865: }
1.134 albertel 4866: my $reply = &put('environment', \%names, $udom,$uname);
4867: if ($reply ne 'ok') { return 'error: '.$reply; }
1.680 www 4868: &devalidate_cache_new('namescache',$uname.':'.$udom);
1.81 www 4869: &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
1.80 www 4870: $umode.', '.$first.', '.$middle.', '.
4871: $last.', '.$gene.' by '.
1.620 albertel 4872: $env{'user.name'}.' at '.$env{'user.domain'});
1.134 albertel 4873: return 'ok';
1.80 www 4874: }
4875:
1.81 www 4876: # -------------------------------------------------------------- Modify student
1.80 www 4877:
1.81 www 4878: sub modifystudent {
4879: my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
1.515 raeburn 4880: $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
1.455 albertel 4881: if (!$cid) {
1.620 albertel 4882: unless ($cid=$env{'request.course.id'}) {
1.455 albertel 4883: return 'not_in_class';
4884: }
1.80 www 4885: }
4886: # --------------------------------------------------------------- Make the user
1.81 www 4887: my $reply=&modifyuser
1.209 matthew 4888: ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
1.387 www 4889: $desiredhome,$email);
1.80 www 4890: unless ($reply eq 'ok') { return $reply; }
1.297 matthew 4891: # This will cause &modify_student_enrollment to get the uid from the
4892: # students environment
4893: $uid = undef if (!$forceid);
1.455 albertel 4894: $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
1.515 raeburn 4895: $gene,$usec,$end,$start,$type,$locktype,$cid);
1.297 matthew 4896: return $reply;
4897: }
4898:
4899: sub modify_student_enrollment {
1.515 raeburn 4900: my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
1.455 albertel 4901: my ($cdom,$cnum,$chome);
4902: if (!$cid) {
1.620 albertel 4903: unless ($cid=$env{'request.course.id'}) {
1.455 albertel 4904: return 'not_in_class';
4905: }
1.620 albertel 4906: $cdom=$env{'course.'.$cid.'.domain'};
4907: $cnum=$env{'course.'.$cid.'.num'};
1.455 albertel 4908: } else {
4909: ($cdom,$cnum)=split(/_/,$cid);
4910: }
1.620 albertel 4911: $chome=$env{'course.'.$cid.'.home'};
1.455 albertel 4912: if (!$chome) {
1.457 raeburn 4913: $chome=&homeserver($cnum,$cdom);
1.297 matthew 4914: }
1.455 albertel 4915: if (!$chome) { return 'unknown_course'; }
1.297 matthew 4916: # Make sure the user exists
1.81 www 4917: my $uhome=&homeserver($uname,$udom);
4918: if (($uhome eq '') || ($uhome eq 'no_host')) {
4919: return 'error: no such user';
4920: }
1.297 matthew 4921: # Get student data if we were not given enough information
4922: if (!defined($first) || $first eq '' ||
4923: !defined($last) || $last eq '' ||
4924: !defined($uid) || $uid eq '' ||
4925: !defined($middle) || $middle eq '' ||
4926: !defined($gene) || $gene eq '') {
1.294 matthew 4927: # They did not supply us with enough data to enroll the student, so
4928: # we need to pick up more information.
1.297 matthew 4929: my %tmp = &get('environment',
1.294 matthew 4930: ['firstname','middlename','lastname', 'generation','id']
1.297 matthew 4931: ,$udom,$uname);
4932:
1.800 albertel 4933: #foreach my $key (keys(%tmp)) {
4934: # &logthis("key $key = ".$tmp{$key});
1.455 albertel 4935: #}
1.294 matthew 4936: $first = $tmp{'firstname'} if (!defined($first) || $first eq '');
4937: $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
4938: $last = $tmp{'lastname'} if (!defined($last) || $last eq '');
1.297 matthew 4939: $gene = $tmp{'generation'} if (!defined($gene) || $gene eq '');
1.294 matthew 4940: $uid = $tmp{'id'} if (!defined($uid) || $uid eq '');
4941: }
1.556 albertel 4942: my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
1.487 albertel 4943: my $reply=cput('classlist',
4944: {"$uname:$udom" =>
1.515 raeburn 4945: join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
1.487 albertel 4946: $cdom,$cnum);
1.81 www 4947: unless (($reply eq 'ok') || ($reply eq 'delayed')) {
4948: return 'error: '.$reply;
1.652 albertel 4949: } else {
4950: &devalidate_getsection_cache($udom,$uname,$cid);
1.81 www 4951: }
1.297 matthew 4952: # Add student role to user
1.83 www 4953: my $uurl='/'.$cid;
1.81 www 4954: $uurl=~s/\_/\//g;
4955: if ($usec) {
4956: $uurl.='/'.$usec;
4957: }
4958: return &assignrole($udom,$uname,$uurl,'st',$end,$start);
1.21 www 4959: }
4960:
1.556 albertel 4961: sub format_name {
4962: my ($firstname,$middlename,$lastname,$generation,$first)=@_;
4963: my $name;
4964: if ($first ne 'lastname') {
4965: $name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
4966: } else {
4967: if ($lastname=~/\S/) {
4968: $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
4969: $name=~s/\s+,/,/;
4970: } else {
4971: $name.= $firstname.' '.$middlename.' '.$generation;
4972: }
4973: }
4974: $name=~s/^\s+//;
4975: $name=~s/\s+$//;
4976: $name=~s/\s+/ /g;
4977: return $name;
4978: }
4979:
1.84 www 4980: # ------------------------------------------------- Write to course preferences
4981:
4982: sub writecoursepref {
4983: my ($courseid,%prefs)=@_;
4984: $courseid=~s/^\///;
4985: $courseid=~s/\_/\//g;
4986: my ($cdomain,$cnum)=split(/\//,$courseid);
4987: my $chome=homeserver($cnum,$cdomain);
4988: if (($chome eq '') || ($chome eq 'no_host')) {
4989: return 'error: no such course';
4990: }
4991: my $cstring='';
1.800 albertel 4992: foreach my $pref (keys(%prefs)) {
4993: $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
1.191 harris41 4994: }
1.84 www 4995: $cstring=~s/\&$//;
4996: return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
4997: }
4998:
4999: # ---------------------------------------------------------- Make/modify course
5000:
5001: sub createcourse {
1.741 raeburn 5002: my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
5003: $course_owner,$crstype)=@_;
1.84 www 5004: $url=&declutter($url);
5005: my $cid='';
1.264 matthew 5006: unless (&allowed('ccc',$udom)) {
1.84 www 5007: return 'refused';
5008: }
5009: # ------------------------------------------------------------------- Create ID
1.674 www 5010: my $uname=int(1+rand(9)).
5011: ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
5012: substr($$.time,0,5).unpack("H8",pack("I32",time)).
1.84 www 5013: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
5014: # ----------------------------------------------- Make sure that does not exist
1.230 stredwic 5015: my $uhome=&homeserver($uname,$udom,'true');
1.84 www 5016: unless (($uhome eq '') || ($uhome eq 'no_host')) {
5017: $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
5018: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
1.230 stredwic 5019: $uhome=&homeserver($uname,$udom,'true');
1.84 www 5020: unless (($uhome eq '') || ($uhome eq 'no_host')) {
5021: return 'error: unable to generate unique course-ID';
5022: }
5023: }
1.264 matthew 5024: # ------------------------------------------------ Check supplied server name
1.620 albertel 5025: $course_server = $env{'user.homeserver'} if (! defined($course_server));
1.264 matthew 5026: if (! exists($libserv{$course_server})) {
5027: return 'error:bad server name '.$course_server;
5028: }
1.84 www 5029: # ------------------------------------------------------------- Make the course
5030: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
1.264 matthew 5031: $course_server);
1.84 www 5032: unless ($reply eq 'ok') { return 'error: '.$reply; }
1.230 stredwic 5033: $uhome=&homeserver($uname,$udom,'true');
1.84 www 5034: if (($uhome eq '') || ($uhome eq 'no_host')) {
5035: return 'error: no such course';
5036: }
1.271 www 5037: # ----------------------------------------------------------------- Course made
1.516 raeburn 5038: # log existence
5039: &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
1.741 raeburn 5040: ':'.&escape($inst_code).':'.&escape($course_owner).':'.
5041: &escape($crstype),$uhome);
1.358 www 5042: &flushcourselogs();
5043: # set toplevel url
1.271 www 5044: my $topurl=$url;
5045: unless ($nonstandard) {
5046: # ------------------------------------------ For standard courses, make top url
5047: my $mapurl=&clutter($url);
1.278 www 5048: if ($mapurl eq '/res/') { $mapurl=''; }
1.620 albertel 5049: $env{'form.initmap'}=(<<ENDINITMAP);
1.271 www 5050: <map>
5051: <resource id="1" type="start"></resource>
5052: <resource id="2" src="$mapurl"></resource>
5053: <resource id="3" type="finish"></resource>
5054: <link index="1" from="1" to="2"></link>
5055: <link index="2" from="2" to="3"></link>
5056: </map>
5057: ENDINITMAP
5058: $topurl=&declutter(
1.638 albertel 5059: &finishuserfileupload($uname,$udom,'initmap','default.sequence')
1.271 www 5060: );
5061: }
5062: # ----------------------------------------------------------- Write preferences
1.84 www 5063: &writecoursepref($udom.'_'.$uname,
5064: ('description' => $description,
1.271 www 5065: 'url' => $topurl));
1.84 www 5066: return '/'.$udom.'/'.$uname;
5067: }
5068:
1.813 albertel 5069: sub is_course {
5070: my ($cdom,$cnum) = @_;
5071: my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
5072: undef,'.');
5073: if (exists($courses{$cdom.'_'.$cnum})) {
5074: return 1;
5075: }
5076: return 0;
5077: }
5078:
1.21 www 5079: # ---------------------------------------------------------- Assign Custom Role
5080:
5081: sub assigncustomrole {
1.357 www 5082: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
1.21 www 5083: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
1.357 www 5084: $end,$start,$deleteflag);
1.21 www 5085: }
5086:
5087: # ----------------------------------------------------------------- Revoke Role
5088:
5089: sub revokerole {
1.357 www 5090: my ($udom,$uname,$url,$role,$deleteflag)=@_;
1.21 www 5091: my $now=time;
1.357 www 5092: return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
1.21 www 5093: }
5094:
5095: # ---------------------------------------------------------- Revoke Custom Role
5096:
5097: sub revokecustomrole {
1.357 www 5098: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
1.21 www 5099: my $now=time;
1.357 www 5100: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
5101: $deleteflag);
1.17 www 5102: }
5103:
1.533 banghart 5104: # ------------------------------------------------------------ Disk usage
1.535 albertel 5105: sub diskusage {
1.533 banghart 5106: my ($udom,$uname,$directoryRoot)=@_;
5107: $directoryRoot =~ s/\/$//;
1.535 albertel 5108: my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
1.514 albertel 5109: return $listing;
1.512 banghart 5110: }
5111:
1.566 banghart 5112: sub is_locked {
5113: my ($file_name, $domain, $user) = @_;
5114: my @check;
5115: my $is_locked;
5116: push @check, $file_name;
1.613 albertel 5117: my %locked = &get('file_permissions',\@check,
1.620 albertel 5118: $env{'user.domain'},$env{'user.name'});
1.615 albertel 5119: my ($tmp)=keys(%locked);
5120: if ($tmp=~/^error:/) { undef(%locked); }
1.745 raeburn 5121:
1.566 banghart 5122: if (ref($locked{$file_name}) eq 'ARRAY') {
1.745 raeburn 5123: $is_locked = 'false';
5124: foreach my $entry (@{$locked{$file_name}}) {
5125: if (ref($entry) eq 'ARRAY') {
1.746 raeburn 5126: $is_locked = 'true';
5127: last;
1.745 raeburn 5128: }
5129: }
1.566 banghart 5130: } else {
5131: $is_locked = 'false';
5132: }
5133: }
5134:
1.759 albertel 5135: sub declutter_portfile {
5136: my ($file) = @_;
5137: &logthis("got $file");
5138: $file =~ s-^(/portfolio/|portfolio/)-/-;
5139: &logthis("ret $file");
5140: return $file;
5141: }
5142:
1.559 banghart 5143: # ------------------------------------------------------------- Mark as Read Only
5144:
5145: sub mark_as_readonly {
5146: my ($domain,$user,$files,$what) = @_;
1.613 albertel 5147: my %current_permissions = &dump('file_permissions',$domain,$user);
1.615 albertel 5148: my ($tmp)=keys(%current_permissions);
5149: if ($tmp=~/^error:/) { undef(%current_permissions); }
1.560 banghart 5150: foreach my $file (@{$files}) {
1.759 albertel 5151: $file = &declutter_portfile($file);
1.561 banghart 5152: push(@{$current_permissions{$file}},$what);
1.559 banghart 5153: }
1.613 albertel 5154: &put('file_permissions',\%current_permissions,$domain,$user);
1.559 banghart 5155: return;
5156: }
5157:
1.572 banghart 5158: # ------------------------------------------------------------Save Selected Files
5159:
5160: sub save_selected_files {
5161: my ($user, $path, @files) = @_;
5162: my $filename = $user."savedfiles";
1.573 banghart 5163: my @other_files = &files_not_in_path($user, $path);
1.574 banghart 5164: open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
1.573 banghart 5165: foreach my $file (@files) {
1.620 albertel 5166: print (OUT $env{'form.currentpath'}.$file."\n");
1.573 banghart 5167: }
5168: foreach my $file (@other_files) {
1.574 banghart 5169: print (OUT $file."\n");
1.572 banghart 5170: }
1.574 banghart 5171: close (OUT);
1.572 banghart 5172: return 'ok';
5173: }
5174:
1.574 banghart 5175: sub clear_selected_files {
5176: my ($user) = @_;
5177: my $filename = $user."savedfiles";
5178: open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
5179: print (OUT undef);
5180: close (OUT);
5181: return ("ok");
5182: }
5183:
1.572 banghart 5184: sub files_in_path {
5185: my ($user, $path) = @_;
5186: my $filename = $user."savedfiles";
5187: my %return_files;
1.574 banghart 5188: open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
1.573 banghart 5189: while (my $line_in = <IN>) {
1.574 banghart 5190: chomp ($line_in);
5191: my @paths_and_file = split (m!/!, $line_in);
5192: my $file_part = pop (@paths_and_file);
5193: my $path_part = join ('/', @paths_and_file);
1.573 banghart 5194: $path_part.='/';
5195: my $path_and_file = $path_part.$file_part;
5196: if ($path_part eq $path) {
5197: $return_files{$file_part}= 'selected';
5198: }
5199: }
1.574 banghart 5200: close (IN);
5201: return (\%return_files);
1.572 banghart 5202: }
5203:
5204: # called in portfolio select mode, to show files selected NOT in current directory
5205: sub files_not_in_path {
5206: my ($user, $path) = @_;
5207: my $filename = $user."savedfiles";
5208: my @return_files;
5209: my $path_part;
1.800 albertel 5210: open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
5211: while (my $line = <IN>) {
1.572 banghart 5212: #ok, I know it's clunky, but I want it to work
1.800 albertel 5213: my @paths_and_file = split(m|/|, $line);
5214: my $file_part = pop(@paths_and_file);
5215: chomp($file_part);
5216: my $path_part = join('/', @paths_and_file);
1.572 banghart 5217: $path_part .= '/';
5218: my $path_and_file = $path_part.$file_part;
5219: if ($path_part ne $path) {
1.800 albertel 5220: push(@return_files, ($path_and_file));
1.572 banghart 5221: }
5222: }
1.800 albertel 5223: close(OUT);
1.574 banghart 5224: return (@return_files);
1.572 banghart 5225: }
5226:
1.745 raeburn 5227: #----------------------------------------------Get portfolio file permissions
1.629 banghart 5228:
1.745 raeburn 5229: sub get_portfile_permissions {
5230: my ($domain,$user) = @_;
1.613 albertel 5231: my %current_permissions = &dump('file_permissions',$domain,$user);
1.615 albertel 5232: my ($tmp)=keys(%current_permissions);
5233: if ($tmp=~/^error:/) { undef(%current_permissions); }
1.745 raeburn 5234: return \%current_permissions;
5235: }
5236:
5237: #---------------------------------------------Get portfolio file access controls
5238:
1.749 raeburn 5239: sub get_access_controls {
1.745 raeburn 5240: my ($current_permissions,$group,$file) = @_;
1.769 albertel 5241: my %access;
5242: my $real_file = $file;
5243: $file =~ s/\.meta$//;
1.745 raeburn 5244: if (defined($file)) {
1.749 raeburn 5245: if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
5246: foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
1.769 albertel 5247: $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
1.749 raeburn 5248: }
5249: }
1.745 raeburn 5250: } else {
1.749 raeburn 5251: foreach my $key (keys(%{$current_permissions})) {
5252: if ($key =~ /\0accesscontrol$/) {
5253: if (defined($group)) {
5254: if ($key !~ m-^\Q$group\E/-) {
5255: next;
5256: }
5257: }
5258: my ($fullpath) = split(/\0/,$key);
5259: if (ref($$current_permissions{$key}) eq 'HASH') {
5260: foreach my $control (keys(%{$$current_permissions{$key}})) {
5261: $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
5262: }
5263: }
5264: }
5265: }
5266: }
5267: return %access;
5268: }
5269:
5270: sub modify_access_controls {
5271: my ($file_name,$changes,$domain,$user)=@_;
5272: my ($outcome,$deloutcome);
5273: my %store_permissions;
5274: my %new_values;
5275: my %new_control;
5276: my %translation;
5277: my @deletions = ();
5278: my $now = time;
5279: if (exists($$changes{'activate'})) {
5280: if (ref($$changes{'activate'}) eq 'HASH') {
5281: my @newitems = sort(keys(%{$$changes{'activate'}}));
5282: my $numnew = scalar(@newitems);
5283: for (my $i=0; $i<$numnew; $i++) {
5284: my $newkey = $newitems[$i];
5285: my $newid = &Apache::loncommon::get_cgi_id();
1.797 raeburn 5286: if ($newkey =~ /^\d+:/) {
5287: $newkey =~ s/^(\d+)/$newid/;
5288: $translation{$1} = $newid;
5289: } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
5290: $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
5291: $translation{$1} = $newid;
5292: }
1.749 raeburn 5293: $new_values{$file_name."\0".$newkey} =
5294: $$changes{'activate'}{$newitems[$i]};
5295: $new_control{$newkey} = $now;
5296: }
5297: }
5298: }
5299: my %todelete;
5300: my %changed_items;
5301: foreach my $action ('delete','update') {
5302: if (exists($$changes{$action})) {
5303: if (ref($$changes{$action}) eq 'HASH') {
5304: foreach my $key (keys(%{$$changes{$action}})) {
5305: my ($itemnum) = ($key =~ /^([^:]+):/);
5306: if ($action eq 'delete') {
5307: $todelete{$itemnum} = 1;
5308: } else {
5309: $changed_items{$itemnum} = $key;
5310: }
5311: }
1.745 raeburn 5312: }
5313: }
1.749 raeburn 5314: }
5315: # get lock on access controls for file.
5316: my $lockhash = {
5317: $file_name."\0".'locked_access_records' => $env{'user.name'}.
5318: ':'.$env{'user.domain'},
5319: };
5320: my $tries = 0;
5321: my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
5322:
5323: while (($gotlock ne 'ok') && $tries <3) {
5324: $tries ++;
5325: sleep 1;
5326: $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
5327: }
5328: if ($gotlock eq 'ok') {
5329: my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
5330: my ($tmp)=keys(%curr_permissions);
5331: if ($tmp=~/^error:/) { undef(%curr_permissions); }
5332: if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
5333: my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
5334: if (ref($curr_controls) eq 'HASH') {
5335: foreach my $control_item (keys(%{$curr_controls})) {
5336: my ($itemnum) = ($control_item =~ /^([^:]+):/);
5337: if (defined($todelete{$itemnum})) {
5338: push(@deletions,$file_name."\0".$control_item);
5339: } else {
5340: if (defined($changed_items{$itemnum})) {
5341: $new_control{$changed_items{$itemnum}} = $now;
5342: push(@deletions,$file_name."\0".$control_item);
5343: $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
5344: } else {
5345: $new_control{$control_item} = $$curr_controls{$control_item};
5346: }
5347: }
1.745 raeburn 5348: }
5349: }
5350: }
1.749 raeburn 5351: $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
5352: $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
5353: $outcome = &put('file_permissions',\%new_values,$domain,$user);
5354: # remove lock
5355: my @del_lock = ($file_name."\0".'locked_access_records');
5356: my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
1.818 raeburn 5357: my ($file,$group);
5358: if (&is_course($domain,$user)) {
5359: ($group,$file) = split(/\//,$file_name,2);
5360: } else {
5361: $file = $file_name;
5362: }
5363: my $sqlresult =
5364: &update_portfolio_table($user,$domain,$file,'portfolio_access',
5365: $group);
1.749 raeburn 5366: } else {
5367: $outcome = "error: could not obtain lockfile\n";
1.745 raeburn 5368: }
1.749 raeburn 5369: return ($outcome,$deloutcome,\%new_values,\%translation);
1.745 raeburn 5370: }
5371:
1.827 raeburn 5372: sub make_public_indefinitely {
5373: my ($requrl) = @_;
5374: my $now = time;
5375: my $action = 'activate';
5376: my $aclnum = 0;
5377: if (&is_portfolio_url($requrl)) {
5378: my (undef,$udom,$unum,$file_name,$group) =
5379: &parse_portfolio_url($requrl);
5380: my $current_perms = &get_portfile_permissions($udom,$unum);
5381: my %access_controls = &get_access_controls($current_perms,
5382: $group,$file_name);
5383: foreach my $key (keys(%{$access_controls{$file_name}})) {
5384: my ($num,$scope,$end,$start) =
5385: ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
5386: if ($scope eq 'public') {
5387: if ($start <= $now && $end == 0) {
5388: $action = 'none';
5389: } else {
5390: $action = 'update';
5391: $aclnum = $num;
5392: }
5393: last;
5394: }
5395: }
5396: if ($action eq 'none') {
5397: return 'ok';
5398: } else {
5399: my %changes;
5400: my $newend = 0;
5401: my $newstart = $now;
5402: my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
5403: $changes{$action}{$newkey} = {
5404: type => 'public',
5405: time => {
5406: start => $newstart,
5407: end => $newend,
5408: },
5409: };
5410: my ($outcome,$deloutcome,$new_values,$translation) =
5411: &modify_access_controls($file_name,\%changes,$udom,$unum);
5412: return $outcome;
5413: }
5414: } else {
5415: return 'invalid';
5416: }
5417: }
5418:
1.745 raeburn 5419: #------------------------------------------------------Get Marked as Read Only
5420:
5421: sub get_marked_as_readonly {
5422: my ($domain,$user,$what,$group) = @_;
5423: my $current_permissions = &get_portfile_permissions($domain,$user);
1.563 banghart 5424: my @readonly_files;
1.629 banghart 5425: my $cmp1=$what;
5426: if (ref($what)) { $cmp1=join('',@{$what}) };
1.745 raeburn 5427: while (my ($file_name,$value) = each(%{$current_permissions})) {
5428: if (defined($group)) {
5429: if ($file_name !~ m-^\Q$group\E/-) {
5430: next;
5431: }
5432: }
1.561 banghart 5433: if (ref($value) eq "ARRAY"){
5434: foreach my $stored_what (@{$value}) {
1.629 banghart 5435: my $cmp2=$stored_what;
1.759 albertel 5436: if (ref($stored_what) eq 'ARRAY') {
1.746 raeburn 5437: $cmp2=join('',@{$stored_what});
1.745 raeburn 5438: }
1.629 banghart 5439: if ($cmp1 eq $cmp2) {
1.561 banghart 5440: push(@readonly_files, $file_name);
1.745 raeburn 5441: last;
1.563 banghart 5442: } elsif (!defined($what)) {
5443: push(@readonly_files, $file_name);
1.745 raeburn 5444: last;
1.561 banghart 5445: }
5446: }
1.745 raeburn 5447: }
1.561 banghart 5448: }
5449: return @readonly_files;
5450: }
1.577 banghart 5451: #-----------------------------------------------------------Get Marked as Read Only Hash
1.561 banghart 5452:
1.577 banghart 5453: sub get_marked_as_readonly_hash {
1.745 raeburn 5454: my ($current_permissions,$group,$what) = @_;
1.577 banghart 5455: my %readonly_files;
1.745 raeburn 5456: while (my ($file_name,$value) = each(%{$current_permissions})) {
5457: if (defined($group)) {
5458: if ($file_name !~ m-^\Q$group\E/-) {
5459: next;
5460: }
5461: }
1.577 banghart 5462: if (ref($value) eq "ARRAY"){
5463: foreach my $stored_what (@{$value}) {
1.745 raeburn 5464: if (ref($stored_what) eq 'ARRAY') {
1.750 banghart 5465: foreach my $lock_descriptor(@{$stored_what}) {
5466: if ($lock_descriptor eq 'graded') {
5467: $readonly_files{$file_name} = 'graded';
5468: } elsif ($lock_descriptor eq 'handback') {
5469: $readonly_files{$file_name} = 'handback';
5470: } else {
5471: if (!exists($readonly_files{$file_name})) {
5472: $readonly_files{$file_name} = 'locked';
5473: }
5474: }
1.745 raeburn 5475: }
1.750 banghart 5476: }
1.577 banghart 5477: }
5478: }
5479: }
5480: return %readonly_files;
5481: }
1.559 banghart 5482: # ------------------------------------------------------------ Unmark as Read Only
5483:
5484: sub unmark_as_readonly {
1.629 banghart 5485: # unmarks $file_name (if $file_name is defined), or all files locked by $what
5486: # for portfolio submissions, $what contains [$symb,$crsid]
1.745 raeburn 5487: my ($domain,$user,$what,$file_name,$group) = @_;
1.759 albertel 5488: $file_name = &declutter_portfile($file_name);
1.634 albertel 5489: my $symb_crs = $what;
5490: if (ref($what)) { $symb_crs=join('',@$what); }
1.745 raeburn 5491: my %current_permissions = &dump('file_permissions',$domain,$user,$group);
1.615 albertel 5492: my ($tmp)=keys(%current_permissions);
5493: if ($tmp=~/^error:/) { undef(%current_permissions); }
1.745 raeburn 5494: my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
1.650 albertel 5495: foreach my $file (@readonly_files) {
1.759 albertel 5496: my $clean_file = &declutter_portfile($file);
5497: if (defined($file_name) && ($file_name ne $clean_file)) { next; }
1.650 albertel 5498: my $current_locks = $current_permissions{$file};
1.563 banghart 5499: my @new_locks;
5500: my @del_keys;
5501: if (ref($current_locks) eq "ARRAY"){
5502: foreach my $locker (@{$current_locks}) {
1.632 albertel 5503: my $compare=$locker;
1.749 raeburn 5504: if (ref($locker) eq 'ARRAY') {
1.745 raeburn 5505: $compare=join('',@{$locker});
1.746 raeburn 5506: if ($compare ne $symb_crs) {
5507: push(@new_locks, $locker);
5508: }
1.563 banghart 5509: }
5510: }
1.650 albertel 5511: if (scalar(@new_locks) > 0) {
1.563 banghart 5512: $current_permissions{$file} = \@new_locks;
5513: } else {
5514: push(@del_keys, $file);
1.613 albertel 5515: &del('file_permissions',\@del_keys, $domain, $user);
1.650 albertel 5516: delete($current_permissions{$file});
1.563 banghart 5517: }
5518: }
1.561 banghart 5519: }
1.613 albertel 5520: &put('file_permissions',\%current_permissions,$domain,$user);
1.559 banghart 5521: return;
5522: }
1.512 banghart 5523:
1.17 www 5524: # ------------------------------------------------------------ Directory lister
5525:
5526: sub dirlist {
1.253 stredwic 5527: my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
5528:
1.18 www 5529: $uri=~s/^\///;
5530: $uri=~s/\/$//;
1.253 stredwic 5531: my ($udom, $uname);
5532: (undef,$udom,$uname)=split(/\//,$uri);
5533: if(defined($userdomain)) {
5534: $udom = $userdomain;
5535: }
5536: if(defined($username)) {
5537: $uname = $username;
5538: }
5539:
5540: my $dirRoot = $perlvar{'lonDocRoot'};
5541: if(defined($alternateDirectoryRoot)) {
5542: $dirRoot = $alternateDirectoryRoot;
5543: $dirRoot =~ s/\/$//;
1.751 banghart 5544: }
1.253 stredwic 5545:
5546: if($udom) {
5547: if($uname) {
1.800 albertel 5548: my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
5549: &homeserver($uname,$udom));
1.605 matthew 5550: my @listing_results;
5551: if ($listing eq 'unknown_cmd') {
1.800 albertel 5552: $listing = &reply('ls:'.$dirRoot.'/'.$uri,
5553: &homeserver($uname,$udom));
1.605 matthew 5554: @listing_results = split(/:/,$listing);
5555: } else {
5556: @listing_results = map { &unescape($_); } split(/:/,$listing);
5557: }
5558: return @listing_results;
1.253 stredwic 5559: } elsif(!defined($alternateDirectoryRoot)) {
1.800 albertel 5560: my %allusers;
5561: foreach my $tryserver (keys(%libserv)) {
1.253 stredwic 5562: if($hostdom{$tryserver} eq $udom) {
1.800 albertel 5563: my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
5564: $udom, $tryserver);
1.605 matthew 5565: my @listing_results;
5566: if ($listing eq 'unknown_cmd') {
1.800 albertel 5567: $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
5568: $udom, $tryserver);
1.605 matthew 5569: @listing_results = split(/:/,$listing);
5570: } else {
5571: @listing_results =
5572: map { &unescape($_); } split(/:/,$listing);
5573: }
5574: if ($listing_results[0] ne 'no_such_dir' &&
5575: $listing_results[0] ne 'empty' &&
5576: $listing_results[0] ne 'con_lost') {
1.800 albertel 5577: foreach my $line (@listing_results) {
5578: my ($entry) = split(/&/,$line,2);
5579: $allusers{$entry} = 1;
1.253 stredwic 5580: }
5581: }
1.191 harris41 5582: }
1.253 stredwic 5583: }
5584: my $alluserstr='';
1.800 albertel 5585: foreach my $user (sort(keys(%allusers))) {
5586: $alluserstr.=$user.'&user:';
1.253 stredwic 5587: }
5588: $alluserstr=~s/:$//;
5589: return split(/:/,$alluserstr);
5590: } else {
1.800 albertel 5591: return ('missing user name');
1.253 stredwic 5592: }
5593: } elsif(!defined($alternateDirectoryRoot)) {
5594: my $tryserver;
5595: my %alldom=();
1.800 albertel 5596: foreach $tryserver (keys(%libserv)) {
1.253 stredwic 5597: $alldom{$hostdom{$tryserver}}=1;
5598: }
5599: my $alldomstr='';
1.800 albertel 5600: foreach my $domain (sort(keys(%alldom))) {
5601: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
1.253 stredwic 5602: }
5603: $alldomstr=~s/:$//;
5604: return split(/:/,$alldomstr);
5605: } else {
1.800 albertel 5606: return ('missing domain');
1.275 stredwic 5607: }
5608: }
5609:
5610: # --------------------------------------------- GetFileTimestamp
5611: # This function utilizes dirlist and returns the date stamp for
5612: # when it was last modified. It will also return an error of -1
5613: # if an error occurs
5614:
1.410 matthew 5615: ##
5616: ## FIXME: This subroutine assumes its caller knows something about the
5617: ## directory structure of the home server for the student ($root).
5618: ## Not a good assumption to make. Since this is for looking up files
5619: ## in user directories, the full path should be constructed by lond, not
5620: ## whatever machine we request data from.
5621: ##
1.275 stredwic 5622: sub GetFileTimestamp {
5623: my ($studentDomain,$studentName,$filename,$root)=@_;
1.807 albertel 5624: $studentDomain = &LONCAPA::clean_domain($studentDomain);
5625: $studentName = &LONCAPA::clean_username($studentName);
1.275 stredwic 5626: my $subdir=$studentName.'__';
5627: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
5628: my $proname="$studentDomain/$subdir/$studentName";
5629: $proname .= '/'.$filename;
1.375 matthew 5630: my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
5631: $studentName, $root);
1.275 stredwic 5632: my @stats = split('&', $fileStat);
5633: if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
1.375 matthew 5634: # @stats contains first the filename, then the stat output
5635: return $stats[10]; # so this is 10 instead of 9.
1.275 stredwic 5636: } else {
5637: return -1;
1.253 stredwic 5638: }
1.26 www 5639: }
5640:
1.712 albertel 5641: sub stat_file {
5642: my ($uri) = @_;
1.787 albertel 5643: $uri = &clutter_with_no_wrapper($uri);
1.722 albertel 5644:
1.712 albertel 5645: my ($udom,$uname,$file,$dir);
5646: if ($uri =~ m-^/(uploaded|editupload)/-) {
5647: ($udom,$uname,$file) =
1.811 albertel 5648: ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
1.712 albertel 5649: $file = 'userfiles/'.$file;
1.740 www 5650: $dir = &propath($udom,$uname);
1.712 albertel 5651: }
5652: if ($uri =~ m-^/res/-) {
5653: ($udom,$uname) =
1.807 albertel 5654: ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
1.712 albertel 5655: $file = $uri;
5656: }
5657:
5658: if (!$udom || !$uname || !$file) {
5659: # unable to handle the uri
5660: return ();
5661: }
5662:
5663: my ($result) = &dirlist($file,$udom,$uname,$dir);
5664: my @stats = split('&', $result);
1.721 banghart 5665:
1.712 albertel 5666: if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
5667: shift(@stats); #filename is first
5668: return @stats;
5669: }
5670: return ();
5671: }
5672:
1.26 www 5673: # -------------------------------------------------------- Value of a Condition
5674:
1.713 albertel 5675: # gets the value of a specific preevaluated condition
5676: # stored in the string $env{user.state.<cid>}
5677: # or looks up a condition reference in the bighash and if if hasn't
5678: # already been evaluated recurses into docondval to get the value of
5679: # the condition, then memoizing it to
5680: # $env{user.state.<cid>.<condition>}
1.40 www 5681: sub directcondval {
5682: my $number=shift;
1.620 albertel 5683: if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
1.555 albertel 5684: &Apache::lonuserstate::evalstate();
5685: }
1.713 albertel 5686: if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
5687: return $env{'user.state.'.$env{'request.course.id'}.".$number"};
5688: } elsif ($number =~ /^_/) {
5689: my $sub_condition;
5690: if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
5691: &GDBM_READER(),0640)) {
5692: $sub_condition=$bighash{'conditions'.$number};
5693: untie(%bighash);
5694: }
5695: my $value = &docondval($sub_condition);
5696: &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
5697: return $value;
5698: }
1.620 albertel 5699: if ($env{'user.state.'.$env{'request.course.id'}}) {
5700: return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
1.40 www 5701: } else {
5702: return 2;
5703: }
5704: }
5705:
1.713 albertel 5706: # get the collection of conditions for this resource
1.26 www 5707: sub condval {
5708: my $condidx=shift;
1.54 www 5709: my $allpathcond='';
1.713 albertel 5710: foreach my $cond (split(/\|/,$condidx)) {
5711: if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
5712: $allpathcond.=
5713: '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
5714: }
1.191 harris41 5715: }
1.54 www 5716: $allpathcond=~s/\|$//;
1.713 albertel 5717: return &docondval($allpathcond);
5718: }
5719:
5720: #evaluates an expression of conditions
5721: sub docondval {
5722: my ($allpathcond) = @_;
5723: my $result=0;
5724: if ($env{'request.course.id'}
5725: && defined($allpathcond)) {
5726: my $operand='|';
5727: my @stack;
5728: foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
5729: if ($chunk eq '(') {
5730: push @stack,($operand,$result);
5731: } elsif ($chunk eq ')') {
5732: my $before=pop @stack;
5733: if (pop @stack eq '&') {
5734: $result=$result>$before?$before:$result;
5735: } else {
5736: $result=$result>$before?$result:$before;
5737: }
5738: } elsif (($chunk eq '&') || ($chunk eq '|')) {
5739: $operand=$chunk;
5740: } else {
5741: my $new=directcondval($chunk);
5742: if ($operand eq '&') {
5743: $result=$result>$new?$new:$result;
5744: } else {
5745: $result=$result>$new?$result:$new;
5746: }
5747: }
5748: }
1.26 www 5749: }
5750: return $result;
1.421 albertel 5751: }
5752:
5753: # ---------------------------------------------------- Devalidate courseresdata
5754:
5755: sub devalidatecourseresdata {
5756: my ($coursenum,$coursedomain)=@_;
5757: my $hashid=$coursenum.':'.$coursedomain;
1.599 albertel 5758: &devalidate_cache_new('courseres',$hashid);
1.28 www 5759: }
5760:
1.763 www 5761:
1.200 www 5762: # --------------------------------------------------- Course Resourcedata Query
5763:
1.624 albertel 5764: sub get_courseresdata {
5765: my ($coursenum,$coursedomain)=@_;
1.200 www 5766: my $coursehom=&homeserver($coursenum,$coursedomain);
5767: my $hashid=$coursenum.':'.$coursedomain;
1.599 albertel 5768: my ($result,$cached)=&is_cached_new('courseres',$hashid);
1.624 albertel 5769: my %dumpreply;
1.417 albertel 5770: unless (defined($cached)) {
1.624 albertel 5771: %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
1.417 albertel 5772: $result=\%dumpreply;
1.251 albertel 5773: my ($tmp) = keys(%dumpreply);
5774: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
1.599 albertel 5775: &do_cache_new('courseres',$hashid,$result,600);
1.306 albertel 5776: } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
5777: return $tmp;
1.416 albertel 5778: } elsif ($tmp =~ /^(error)/) {
1.417 albertel 5779: $result=undef;
1.599 albertel 5780: &do_cache_new('courseres',$hashid,$result,600);
1.250 albertel 5781: }
5782: }
1.624 albertel 5783: return $result;
5784: }
5785:
1.633 albertel 5786: sub devalidateuserresdata {
5787: my ($uname,$udom)=@_;
5788: my $hashid="$udom:$uname";
5789: &devalidate_cache_new('userres',$hashid);
5790: }
5791:
1.624 albertel 5792: sub get_userresdata {
5793: my ($uname,$udom)=@_;
5794: #most student don\'t have any data set, check if there is some data
5795: if (&EXT_cache_status($udom,$uname)) { return undef; }
5796:
5797: my $hashid="$udom:$uname";
5798: my ($result,$cached)=&is_cached_new('userres',$hashid);
5799: if (!defined($cached)) {
5800: my %resourcedata=&dump('resourcedata',$udom,$uname);
5801: $result=\%resourcedata;
5802: &do_cache_new('userres',$hashid,$result,600);
5803: }
5804: my ($tmp)=keys(%$result);
5805: if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
5806: return $result;
5807: }
5808: #error 2 occurs when the .db doesn't exist
5809: if ($tmp!~/error: 2 /) {
1.672 albertel 5810: &logthis("<font color=\"blue\">WARNING:".
1.624 albertel 5811: " Trying to get resource data for ".
5812: $uname." at ".$udom.": ".
5813: $tmp."</font>");
5814: } elsif ($tmp=~/error: 2 /) {
1.633 albertel 5815: #&EXT_cache_set($udom,$uname);
5816: &do_cache_new('userres',$hashid,undef,600);
1.636 albertel 5817: undef($tmp); # not really an error so don't send it back
1.624 albertel 5818: }
5819: return $tmp;
5820: }
5821:
5822: sub resdata {
5823: my ($name,$domain,$type,@which)=@_;
5824: my $result;
5825: if ($type eq 'course') {
5826: $result=&get_courseresdata($name,$domain);
5827: } elsif ($type eq 'user') {
5828: $result=&get_userresdata($name,$domain);
5829: }
5830: if (!ref($result)) { return $result; }
1.251 albertel 5831: foreach my $item (@which) {
1.417 albertel 5832: if (defined($result->{$item})) {
5833: return $result->{$item};
1.251 albertel 5834: }
1.250 albertel 5835: }
1.291 albertel 5836: return undef;
1.200 www 5837: }
5838:
1.379 matthew 5839: #
5840: # EXT resource caching routines
5841: #
5842:
5843: sub clear_EXT_cache_status {
1.383 albertel 5844: &delenv('cache.EXT.');
1.379 matthew 5845: }
5846:
5847: sub EXT_cache_status {
5848: my ($target_domain,$target_user) = @_;
1.383 albertel 5849: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.620 albertel 5850: if (exists($env{$cachename}) && ($env{$cachename}+600) > time) {
1.379 matthew 5851: # We know already the user has no data
5852: return 1;
5853: } else {
5854: return 0;
5855: }
5856: }
5857:
5858: sub EXT_cache_set {
5859: my ($target_domain,$target_user) = @_;
1.383 albertel 5860: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.633 albertel 5861: #&appenv($cachename => time);
1.379 matthew 5862: }
5863:
1.28 www 5864: # --------------------------------------------------------- Value of a Variable
1.58 www 5865: sub EXT {
1.715 albertel 5866:
1.395 albertel 5867: my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
1.68 www 5868: unless ($varname) { return ''; }
1.218 albertel 5869: #get real user name/domain, courseid and symb
5870: my $courseid;
1.359 albertel 5871: my $publicuser;
1.427 www 5872: if ($symbparm) {
5873: $symbparm=&get_symb_from_alias($symbparm);
5874: }
1.218 albertel 5875: if (!($uname && $udom)) {
1.790 albertel 5876: (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
1.218 albertel 5877: if (!$symbparm) { $symbparm=$cursymb; }
5878: } else {
1.620 albertel 5879: $courseid=$env{'request.course.id'};
1.218 albertel 5880: }
1.48 www 5881: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
5882: my $rest;
1.320 albertel 5883: if (defined($therest[0])) {
1.48 www 5884: $rest=join('.',@therest);
5885: } else {
5886: $rest='';
5887: }
1.320 albertel 5888:
1.57 www 5889: my $qualifierrest=$qualifier;
5890: if ($rest) { $qualifierrest.='.'.$rest; }
5891: my $spacequalifierrest=$space;
5892: if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28 www 5893: if ($realm eq 'user') {
1.48 www 5894: # --------------------------------------------------------------- user.resource
5895: if ($space eq 'resource') {
1.651 albertel 5896: if ( (defined($Apache::lonhomework::parsing_a_problem)
5897: || defined($Apache::lonhomework::parsing_a_task))
5898: &&
1.744 albertel 5899: ($symbparm eq &symbread()) ) {
5900: # if we are in the middle of processing the resource the
5901: # get the value we are planning on committing
5902: if (defined($Apache::lonhomework::results{$qualifierrest})) {
5903: return $Apache::lonhomework::results{$qualifierrest};
5904: } else {
5905: return $Apache::lonhomework::history{$qualifierrest};
5906: }
1.335 albertel 5907: } else {
1.359 albertel 5908: my %restored;
1.620 albertel 5909: if ($publicuser || $env{'request.state'} eq 'construct') {
1.359 albertel 5910: %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
5911: } else {
5912: %restored=&restore($symbparm,$courseid,$udom,$uname);
5913: }
1.335 albertel 5914: return $restored{$qualifierrest};
5915: }
1.48 www 5916: # ----------------------------------------------------------------- user.access
5917: } elsif ($space eq 'access') {
1.218 albertel 5918: # FIXME - not supporting calls for a specific user
1.48 www 5919: return &allowed($qualifier,$rest);
5920: # ------------------------------------------ user.preferences, user.environment
5921: } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.620 albertel 5922: if (($uname eq $env{'user.name'}) &&
5923: ($udom eq $env{'user.domain'})) {
5924: return $env{join('.',('environment',$qualifierrest))};
1.218 albertel 5925: } else {
1.359 albertel 5926: my %returnhash;
5927: if (!$publicuser) {
5928: %returnhash=&userenvironment($udom,$uname,
5929: $qualifierrest);
5930: }
1.218 albertel 5931: return $returnhash{$qualifierrest};
5932: }
1.48 www 5933: # ----------------------------------------------------------------- user.course
5934: } elsif ($space eq 'course') {
1.218 albertel 5935: # FIXME - not supporting calls for a specific user
1.620 albertel 5936: return $env{join('.',('request.course',$qualifier))};
1.48 www 5937: # ------------------------------------------------------------------- user.role
5938: } elsif ($space eq 'role') {
1.218 albertel 5939: # FIXME - not supporting calls for a specific user
1.620 albertel 5940: my ($role,$where)=split(/\./,$env{'request.role'});
1.48 www 5941: if ($qualifier eq 'value') {
5942: return $role;
5943: } elsif ($qualifier eq 'extent') {
5944: return $where;
5945: }
5946: # ----------------------------------------------------------------- user.domain
5947: } elsif ($space eq 'domain') {
1.218 albertel 5948: return $udom;
1.48 www 5949: # ------------------------------------------------------------------- user.name
5950: } elsif ($space eq 'name') {
1.218 albertel 5951: return $uname;
1.48 www 5952: # ---------------------------------------------------- Any other user namespace
1.29 www 5953: } else {
1.359 albertel 5954: my %reply;
5955: if (!$publicuser) {
5956: %reply=&get($space,[$qualifierrest],$udom,$uname);
5957: }
5958: return $reply{$qualifierrest};
1.48 www 5959: }
1.236 www 5960: } elsif ($realm eq 'query') {
5961: # ---------------------------------------------- pull stuff out of query string
1.384 albertel 5962: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
5963: [$spacequalifierrest]);
1.620 albertel 5964: return $env{'form.'.$spacequalifierrest};
1.236 www 5965: } elsif ($realm eq 'request') {
1.48 www 5966: # ------------------------------------------------------------- request.browser
5967: if ($space eq 'browser') {
1.430 www 5968: if ($qualifier eq 'textremote') {
1.676 albertel 5969: if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
1.430 www 5970: return 1;
5971: } else {
5972: return 0;
5973: }
5974: } else {
1.620 albertel 5975: return $env{'browser.'.$qualifier};
1.430 www 5976: }
1.57 www 5977: # ------------------------------------------------------------ request.filename
5978: } else {
1.620 albertel 5979: return $env{'request.'.$spacequalifierrest};
1.29 www 5980: }
1.28 www 5981: } elsif ($realm eq 'course') {
1.48 www 5982: # ---------------------------------------------------------- course.description
1.620 albertel 5983: return $env{'course.'.$courseid.'.'.$spacequalifierrest};
1.57 www 5984: } elsif ($realm eq 'resource') {
1.165 www 5985:
1.620 albertel 5986: if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
1.539 albertel 5987: if (!$symbparm) { $symbparm=&symbread(); }
5988: }
1.693 albertel 5989:
5990: if ($space eq 'title') {
5991: if (!$symbparm) { $symbparm = $env{'request.filename'}; }
5992: return &gettitle($symbparm);
5993: }
5994:
5995: if ($space eq 'map') {
5996: my ($map) = &decode_symb($symbparm);
5997: return &symbread($map);
5998: }
5999:
6000: my ($section, $group, @groups);
1.593 albertel 6001: my ($courselevelm,$courselevel);
1.539 albertel 6002: if ($symbparm && defined($courseid) &&
1.620 albertel 6003: $courseid eq $env{'request.course.id'}) {
1.165 www 6004:
1.218 albertel 6005: #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
1.165 www 6006:
1.60 www 6007: # ----------------------------------------------------- Cascading lookup scheme
1.218 albertel 6008: my $symbp=$symbparm;
1.735 albertel 6009: my $mapp=&deversion((&decode_symb($symbp))[0]);
1.218 albertel 6010:
6011: my $symbparm=$symbp.'.'.$spacequalifierrest;
6012: my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
6013:
1.620 albertel 6014: if (($env{'user.name'} eq $uname) &&
6015: ($env{'user.domain'} eq $udom)) {
6016: $section=$env{'request.course.sec'};
1.733 raeburn 6017: @groups = split(/:/,$env{'request.course.groups'});
6018: @groups=&sort_course_groups($courseid,@groups);
1.218 albertel 6019: } else {
1.539 albertel 6020: if (! defined($usection)) {
1.551 albertel 6021: $section=&getsection($udom,$uname,$courseid);
1.539 albertel 6022: } else {
6023: $section = $usection;
6024: }
1.733 raeburn 6025: @groups = &get_users_groups($udom,$uname,$courseid);
1.218 albertel 6026: }
6027:
6028: my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
6029: my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
6030: my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
6031:
1.593 albertel 6032: $courselevel=$courseid.'.'.$spacequalifierrest;
1.218 albertel 6033: my $courselevelr=$courseid.'.'.$symbparm;
1.593 albertel 6034: $courselevelm=$courseid.'.'.$mapparm;
1.69 www 6035:
1.60 www 6036: # ----------------------------------------------------------- first, check user
1.624 albertel 6037:
6038: my $userreply=&resdata($uname,$udom,'user',
6039: ($courselevelr,$courselevelm,
6040: $courselevel));
6041: if (defined($userreply)) { return $userreply; }
1.95 www 6042:
1.594 albertel 6043: # ------------------------------------------------ second, check some of course
1.684 raeburn 6044: my $coursereply;
1.691 raeburn 6045: if (@groups > 0) {
6046: $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
6047: $mapparm,$spacequalifierrest);
1.684 raeburn 6048: if (defined($coursereply)) { return $coursereply; }
6049: }
1.96 www 6050:
1.684 raeburn 6051: $coursereply=&resdata($env{'course.'.$courseid.'.num'},
1.624 albertel 6052: $env{'course.'.$courseid.'.domain'},
6053: 'course',
6054: ($seclevelr,$seclevelm,$seclevel,
6055: $courselevelr));
1.287 albertel 6056: if (defined($coursereply)) { return $coursereply; }
1.200 www 6057:
1.60 www 6058: # ------------------------------------------------------ third, check map parms
1.218 albertel 6059: my %parmhash=();
6060: my $thisparm='';
6061: if (tie(%parmhash,'GDBM_File',
1.620 albertel 6062: $env{'request.course.fn'}.'_parms.db',
1.256 albertel 6063: &GDBM_READER(),0640)) {
1.218 albertel 6064: $thisparm=$parmhash{$symbparm};
6065: untie(%parmhash);
6066: }
6067: if ($thisparm) { return $thisparm; }
6068: }
1.594 albertel 6069: # ------------------------------------------ fourth, look in resource metadata
1.71 www 6070:
1.218 albertel 6071: $spacequalifierrest=~s/\./\_/;
1.282 albertel 6072: my $filename;
6073: if (!$symbparm) { $symbparm=&symbread(); }
6074: if ($symbparm) {
1.409 www 6075: $filename=(&decode_symb($symbparm))[2];
1.282 albertel 6076: } else {
1.620 albertel 6077: $filename=$env{'request.filename'};
1.282 albertel 6078: }
6079: my $metadata=&metadata($filename,$spacequalifierrest);
1.288 albertel 6080: if (defined($metadata)) { return $metadata; }
1.282 albertel 6081: $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
1.288 albertel 6082: if (defined($metadata)) { return $metadata; }
1.142 www 6083:
1.594 albertel 6084: # ---------------------------------------------- fourth, look in rest pf course
1.593 albertel 6085: if ($symbparm && defined($courseid) &&
1.620 albertel 6086: $courseid eq $env{'request.course.id'}) {
1.624 albertel 6087: my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
6088: $env{'course.'.$courseid.'.domain'},
6089: 'course',
6090: ($courselevelm,$courselevel));
1.593 albertel 6091: if (defined($coursereply)) { return $coursereply; }
6092: }
1.145 www 6093: # ------------------------------------------------------------------ Cascade up
1.218 albertel 6094: unless ($space eq '0') {
1.336 albertel 6095: my @parts=split(/_/,$space);
6096: my $id=pop(@parts);
6097: my $part=join('_',@parts);
6098: if ($part eq '') { $part='0'; }
6099: my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
1.395 albertel 6100: $symbparm,$udom,$uname,$section,1);
1.337 albertel 6101: if (defined($partgeneral)) { return $partgeneral; }
1.218 albertel 6102: }
1.395 albertel 6103: if ($recurse) { return undef; }
6104: my $pack_def=&packages_tab_default($filename,$varname);
6105: if (defined($pack_def)) { return $pack_def; }
1.71 www 6106:
1.48 www 6107: # ---------------------------------------------------- Any other user namespace
6108: } elsif ($realm eq 'environment') {
6109: # ----------------------------------------------------------------- environment
1.620 albertel 6110: if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
6111: return $env{'environment.'.$spacequalifierrest};
1.219 albertel 6112: } else {
1.770 albertel 6113: if ($uname eq 'anonymous' && $udom eq '') {
6114: return '';
6115: }
1.219 albertel 6116: my %returnhash=&userenvironment($udom,$uname,
6117: $spacequalifierrest);
6118: return $returnhash{$spacequalifierrest};
6119: }
1.28 www 6120: } elsif ($realm eq 'system') {
1.48 www 6121: # ----------------------------------------------------------------- system.time
6122: if ($space eq 'time') {
6123: return time;
6124: }
1.696 albertel 6125: } elsif ($realm eq 'server') {
6126: # ----------------------------------------------------------------- system.time
6127: if ($space eq 'name') {
6128: return $ENV{'SERVER_NAME'};
6129: }
1.28 www 6130: }
1.48 www 6131: return '';
1.61 www 6132: }
6133:
1.691 raeburn 6134: sub check_group_parms {
6135: my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
6136: my @groupitems = ();
6137: my $resultitem;
6138: my @levels = ($symbparm,$mapparm,$what);
6139: foreach my $group (@{$groups}) {
6140: foreach my $level (@levels) {
6141: my $item = $courseid.'.['.$group.'].'.$level;
6142: push(@groupitems,$item);
6143: }
6144: }
6145: my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
6146: $env{'course.'.$courseid.'.domain'},
6147: 'course',@groupitems);
6148: return $coursereply;
6149: }
6150:
6151: sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
1.733 raeburn 6152: my ($courseid,@groups) = @_;
6153: @groups = sort(@groups);
1.691 raeburn 6154: return @groups;
6155: }
6156:
1.395 albertel 6157: sub packages_tab_default {
6158: my ($uri,$varname)=@_;
6159: my (undef,$part,$name)=split(/\./,$varname);
1.738 albertel 6160:
6161: my (@extension,@specifics,$do_default);
6162: foreach my $package (split(/,/,&metadata($uri,'packages'))) {
1.395 albertel 6163: my ($pack_type,$pack_part)=split(/_/,$package,2);
1.738 albertel 6164: if ($pack_type eq 'default') {
6165: $do_default=1;
6166: } elsif ($pack_type eq 'extension') {
6167: push(@extension,[$package,$pack_type,$pack_part]);
6168: } else {
6169: push(@specifics,[$package,$pack_type,$pack_part]);
6170: }
6171: }
6172: # first look for a package that matches the requested part id
6173: foreach my $package (@specifics) {
6174: my (undef,$pack_type,$pack_part)=@{$package};
6175: next if ($pack_part ne $part);
6176: if (defined($packagetab{"$pack_type&$name&default"})) {
6177: return $packagetab{"$pack_type&$name&default"};
6178: }
6179: }
6180: # look for any possible matching non extension_ package
6181: foreach my $package (@specifics) {
6182: my (undef,$pack_type,$pack_part)=@{$package};
1.468 albertel 6183: if (defined($packagetab{"$pack_type&$name&default"})) {
6184: return $packagetab{"$pack_type&$name&default"};
6185: }
1.585 albertel 6186: if ($pack_type eq 'part') { $pack_part='0'; }
1.468 albertel 6187: if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
6188: return $packagetab{$pack_type."_".$pack_part."&$name&default"};
1.395 albertel 6189: }
6190: }
1.738 albertel 6191: # look for any posible extension_ match
6192: foreach my $package (@extension) {
6193: my ($package,$pack_type)=@{$package};
6194: if (defined($packagetab{"$pack_type&$name&default"})) {
6195: return $packagetab{"$pack_type&$name&default"};
6196: }
6197: if (defined($packagetab{$package."&$name&default"})) {
6198: return $packagetab{$package."&$name&default"};
6199: }
6200: }
6201: # look for a global default setting
6202: if ($do_default && defined($packagetab{"default&$name&default"})) {
6203: return $packagetab{"default&$name&default"};
6204: }
1.395 albertel 6205: return undef;
6206: }
6207:
1.334 albertel 6208: sub add_prefix_and_part {
6209: my ($prefix,$part)=@_;
6210: my $keyroot;
6211: if (defined($prefix) && $prefix !~ /^__/) {
6212: # prefix that has a part already
6213: $keyroot=$prefix;
6214: } elsif (defined($prefix)) {
6215: # prefix that is missing a part
6216: if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
6217: } else {
6218: # no prefix at all
6219: if (defined($part)) { $keyroot='_'.$part; }
6220: }
6221: return $keyroot;
6222: }
6223:
1.71 www 6224: # ---------------------------------------------------------------- Get metadata
6225:
1.599 albertel 6226: my %metaentry;
1.71 www 6227: sub metadata {
1.176 www 6228: my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
1.71 www 6229: $uri=&declutter($uri);
1.288 albertel 6230: # if it is a non metadata possible uri return quickly
1.529 albertel 6231: if (($uri eq '') ||
6232: (($uri =~ m|^/*adm/|) &&
1.698 albertel 6233: ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
1.423 albertel 6234: ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
1.807 albertel 6235: ($uri =~ m|home/$match_username/public_html/|)) {
1.468 albertel 6236: return undef;
1.288 albertel 6237: }
1.73 www 6238: my $filename=$uri;
6239: $uri=~s/\.meta$//;
1.172 www 6240: #
6241: # Is the metadata already cached?
1.177 www 6242: # Look at timestamp of caching
1.172 www 6243: # Everything is cached by the main uri, libraries are never directly cached
6244: #
1.428 albertel 6245: if (!defined($liburi)) {
1.599 albertel 6246: my ($result,$cached)=&is_cached_new('meta',$uri);
1.428 albertel 6247: if (defined($cached)) { return $result->{':'.$what}; }
6248: }
6249: {
1.172 www 6250: #
6251: # Is this a recursive call for a library?
6252: #
1.599 albertel 6253: # if (! exists($metacache{$uri})) {
6254: # $metacache{$uri}={};
6255: # }
1.171 www 6256: if ($liburi) {
6257: $liburi=&declutter($liburi);
6258: $filename=$liburi;
1.401 bowersj2 6259: } else {
1.599 albertel 6260: &devalidate_cache_new('meta',$uri);
6261: undef(%metaentry);
1.401 bowersj2 6262: }
1.140 www 6263: my %metathesekeys=();
1.73 www 6264: unless ($filename=~/\.meta$/) { $filename.='.meta'; }
1.489 albertel 6265: my $metastring;
1.768 albertel 6266: if ($uri !~ m -^(editupload)/-) {
1.543 albertel 6267: my $file=&filelocation('',&clutter($filename));
1.599 albertel 6268: #push(@{$metaentry{$uri.'.file'}},$file);
1.543 albertel 6269: $metastring=&getfile($file);
1.489 albertel 6270: }
1.208 albertel 6271: my $parser=HTML::LCParser->new(\$metastring);
1.71 www 6272: my $token;
1.140 www 6273: undef %metathesekeys;
1.71 www 6274: while ($token=$parser->get_token) {
1.339 albertel 6275: if ($token->[0] eq 'S') {
6276: if (defined($token->[2]->{'package'})) {
1.172 www 6277: #
6278: # This is a package - get package info
6279: #
1.339 albertel 6280: my $package=$token->[2]->{'package'};
6281: my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
6282: if (defined($token->[2]->{'id'})) {
6283: $keyroot.='_'.$token->[2]->{'id'};
6284: }
1.599 albertel 6285: if ($metaentry{':packages'}) {
6286: $metaentry{':packages'}.=','.$package.$keyroot;
1.339 albertel 6287: } else {
1.599 albertel 6288: $metaentry{':packages'}=$package.$keyroot;
1.339 albertel 6289: }
1.736 albertel 6290: foreach my $pack_entry (keys(%packagetab)) {
1.432 albertel 6291: my $part=$keyroot;
6292: $part=~s/^\_//;
1.736 albertel 6293: if ($pack_entry=~/^\Q$package\E\&/ ||
6294: $pack_entry=~/^\Q$package\E_0\&/) {
6295: my ($pack,$name,$subp)=split(/\&/,$pack_entry);
1.395 albertel 6296: # ignore package.tab specified default values
6297: # here &package_tab_default() will fetch those
6298: if ($subp eq 'default') { next; }
1.736 albertel 6299: my $value=$packagetab{$pack_entry};
1.432 albertel 6300: my $unikey;
6301: if ($pack =~ /_0$/) {
6302: $unikey='parameter_0_'.$name;
6303: $part=0;
6304: } else {
6305: $unikey='parameter'.$keyroot.'_'.$name;
6306: }
1.339 albertel 6307: if ($subp eq 'display') {
6308: $value.=' [Part: '.$part.']';
6309: }
1.599 albertel 6310: $metaentry{':'.$unikey.'.part'}=$part;
1.395 albertel 6311: $metathesekeys{$unikey}=1;
1.599 albertel 6312: unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
6313: $metaentry{':'.$unikey.'.'.$subp}=$value;
1.339 albertel 6314: }
1.599 albertel 6315: if (defined($metaentry{':'.$unikey.'.default'})) {
6316: $metaentry{':'.$unikey}=
6317: $metaentry{':'.$unikey.'.default'};
1.356 albertel 6318: }
1.339 albertel 6319: }
6320: }
6321: } else {
1.172 www 6322: #
6323: # This is not a package - some other kind of start tag
1.339 albertel 6324: #
6325: my $entry=$token->[1];
6326: my $unikey;
6327: if ($entry eq 'import') {
6328: $unikey='';
6329: } else {
6330: $unikey=$entry;
6331: }
6332: $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
6333:
6334: if (defined($token->[2]->{'id'})) {
6335: $unikey.='_'.$token->[2]->{'id'};
6336: }
1.175 www 6337:
1.339 albertel 6338: if ($entry eq 'import') {
1.175 www 6339: #
6340: # Importing a library here
1.339 albertel 6341: #
6342: if ($depthcount<20) {
6343: my $location=$parser->get_text('/import');
6344: my $dir=$filename;
6345: $dir=~s|[^/]*$||;
6346: $location=&filelocation($dir,$location);
1.736 albertel 6347: my $metadata =
6348: &metadata($uri,'keys', $location,$unikey,
6349: $depthcount+1);
6350: foreach my $meta (split(',',$metadata)) {
6351: $metaentry{':'.$meta}=$metaentry{':'.$meta};
6352: $metathesekeys{$meta}=1;
1.339 albertel 6353: }
6354: }
6355: } else {
6356:
6357: if (defined($token->[2]->{'name'})) {
6358: $unikey.='_'.$token->[2]->{'name'};
6359: }
6360: $metathesekeys{$unikey}=1;
1.736 albertel 6361: foreach my $param (@{$token->[3]}) {
6362: $metaentry{':'.$unikey.'.'.$param} =
6363: $token->[2]->{$param};
1.339 albertel 6364: }
6365: my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
1.599 albertel 6366: my $default=$metaentry{':'.$unikey.'.default'};
1.339 albertel 6367: if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
6368: # only ws inside the tag, and not in default, so use default
6369: # as value
1.599 albertel 6370: $metaentry{':'.$unikey}=$default;
1.339 albertel 6371: } else {
1.321 albertel 6372: # either something interesting inside the tag or default
6373: # uninteresting
1.599 albertel 6374: $metaentry{':'.$unikey}=$internaltext;
1.339 albertel 6375: }
1.172 www 6376: # end of not-a-package not-a-library import
1.339 albertel 6377: }
1.172 www 6378: # end of not-a-package start tag
1.339 albertel 6379: }
1.172 www 6380: # the next is the end of "start tag"
1.339 albertel 6381: }
6382: }
1.483 albertel 6383: my ($extension) = ($uri =~ /\.(\w+)$/);
1.737 albertel 6384: foreach my $key (keys(%packagetab)) {
1.483 albertel 6385: #no specific packages #how's our extension
6386: if ($key!~/^extension_\Q$extension\E&/) { next; }
1.488 albertel 6387: &metadata_create_package_def($uri,$key,'extension_'.$extension,
1.483 albertel 6388: \%metathesekeys);
6389: }
1.599 albertel 6390: if (!exists($metaentry{':packages'})) {
1.737 albertel 6391: foreach my $key (keys(%packagetab)) {
1.483 albertel 6392: #no specific packages well let's get default then
6393: if ($key!~/^default&/) { next; }
1.488 albertel 6394: &metadata_create_package_def($uri,$key,'default',
1.483 albertel 6395: \%metathesekeys);
6396: }
6397: }
1.338 www 6398: # are there custom rights to evaluate
1.599 albertel 6399: if ($metaentry{':copyright'} eq 'custom') {
1.339 albertel 6400:
1.338 www 6401: #
6402: # Importing a rights file here
1.339 albertel 6403: #
6404: unless ($depthcount) {
1.599 albertel 6405: my $location=$metaentry{':customdistributionfile'};
1.339 albertel 6406: my $dir=$filename;
6407: $dir=~s|[^/]*$||;
6408: $location=&filelocation($dir,$location);
1.736 albertel 6409: my $rights_metadata =
6410: &metadata($uri,'keys',$location,'_rights',
6411: $depthcount+1);
6412: foreach my $rights (split(',',$rights_metadata)) {
6413: #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
6414: $metathesekeys{$rights}=1;
1.339 albertel 6415: }
6416: }
6417: }
1.737 albertel 6418: # uniqifiy package listing
6419: my %seen;
6420: my @uniq_packages =
6421: grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
6422: $metaentry{':packages'} = join(',',@uniq_packages);
6423:
6424: $metaentry{':keys'} = join(',',keys(%metathesekeys));
1.599 albertel 6425: &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
6426: $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
1.699 albertel 6427: &do_cache_new('meta',$uri,\%metaentry,60*60);
1.177 www 6428: # this is the end of "was not already recently cached
1.71 www 6429: }
1.599 albertel 6430: return $metaentry{':'.$what};
1.261 albertel 6431: }
6432:
1.488 albertel 6433: sub metadata_create_package_def {
1.483 albertel 6434: my ($uri,$key,$package,$metathesekeys)=@_;
6435: my ($pack,$name,$subp)=split(/\&/,$key);
6436: if ($subp eq 'default') { next; }
6437:
1.599 albertel 6438: if (defined($metaentry{':packages'})) {
6439: $metaentry{':packages'}.=','.$package;
1.483 albertel 6440: } else {
1.599 albertel 6441: $metaentry{':packages'}=$package;
1.483 albertel 6442: }
6443: my $value=$packagetab{$key};
6444: my $unikey;
6445: $unikey='parameter_0_'.$name;
1.599 albertel 6446: $metaentry{':'.$unikey.'.part'}=0;
1.483 albertel 6447: $$metathesekeys{$unikey}=1;
1.599 albertel 6448: unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
6449: $metaentry{':'.$unikey.'.'.$subp}=$value;
1.483 albertel 6450: }
1.599 albertel 6451: if (defined($metaentry{':'.$unikey.'.default'})) {
6452: $metaentry{':'.$unikey}=
6453: $metaentry{':'.$unikey.'.default'};
1.483 albertel 6454: }
6455: }
6456:
1.261 albertel 6457: sub metadata_generate_part0 {
6458: my ($metadata,$metacache,$uri) = @_;
6459: my %allnames;
1.737 albertel 6460: foreach my $metakey (keys(%$metadata)) {
1.261 albertel 6461: if ($metakey=~/^parameter\_(.*)/) {
1.428 albertel 6462: my $part=$$metacache{':'.$metakey.'.part'};
6463: my $name=$$metacache{':'.$metakey.'.name'};
1.356 albertel 6464: if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
1.261 albertel 6465: $allnames{$name}=$part;
6466: }
6467: }
6468: }
6469: foreach my $name (keys(%allnames)) {
6470: $$metadata{"parameter_0_$name"}=1;
1.428 albertel 6471: my $key=":parameter_0_$name";
1.261 albertel 6472: $$metacache{"$key.part"}='0';
6473: $$metacache{"$key.name"}=$name;
1.428 albertel 6474: $$metacache{"$key.type"}=$$metacache{':parameter_'.
1.261 albertel 6475: $allnames{$name}.'_'.$name.
6476: '.type'};
1.428 albertel 6477: my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
1.261 albertel 6478: '.display'};
1.644 www 6479: my $expr='[Part: '.$allnames{$name}.']';
1.479 albertel 6480: $olddis=~s/\Q$expr\E/\[Part: 0\]/;
1.261 albertel 6481: $$metacache{"$key.display"}=$olddis;
6482: }
1.71 www 6483: }
6484:
1.764 albertel 6485: # ------------------------------------------------------ Devalidate title cache
6486:
6487: sub devalidate_title_cache {
6488: my ($url)=@_;
6489: if (!$env{'request.course.id'}) { return; }
6490: my $symb=&symbread($url);
6491: if (!$symb) { return; }
6492: my $key=$env{'request.course.id'}."\0".$symb;
6493: &devalidate_cache_new('title',$key);
6494: }
6495:
1.301 www 6496: # ------------------------------------------------- Get the title of a resource
6497:
6498: sub gettitle {
6499: my $urlsymb=shift;
6500: my $symb=&symbread($urlsymb);
1.534 albertel 6501: if ($symb) {
1.620 albertel 6502: my $key=$env{'request.course.id'}."\0".$symb;
1.599 albertel 6503: my ($result,$cached)=&is_cached_new('title',$key);
1.575 albertel 6504: if (defined($cached)) {
6505: return $result;
6506: }
1.534 albertel 6507: my ($map,$resid,$url)=&decode_symb($symb);
6508: my $title='';
6509: my %bighash;
1.620 albertel 6510: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.534 albertel 6511: &GDBM_READER(),0640)) {
6512: my $mapid=$bighash{'map_pc_'.&clutter($map)};
6513: $title=$bighash{'title_'.$mapid.'.'.$resid};
6514: untie %bighash;
6515: }
6516: $title=~s/\&colon\;/\:/gs;
6517: if ($title) {
1.599 albertel 6518: return &do_cache_new('title',$key,$title,600);
1.534 albertel 6519: }
6520: $urlsymb=$url;
6521: }
6522: my $title=&metadata($urlsymb,'title');
6523: if (!$title) { $title=(split('/',$urlsymb))[-1]; }
6524: return $title;
1.301 www 6525: }
1.613 albertel 6526:
1.614 albertel 6527: sub get_slot {
6528: my ($which,$cnum,$cdom)=@_;
6529: if (!$cnum || !$cdom) {
1.790 albertel 6530: (undef,my $courseid)=&whichuser();
1.620 albertel 6531: $cdom=$env{'course.'.$courseid.'.domain'};
6532: $cnum=$env{'course.'.$courseid.'.num'};
1.614 albertel 6533: }
1.703 albertel 6534: my $key=join("\0",'slots',$cdom,$cnum,$which);
6535: my %slotinfo;
6536: if (exists($remembered{$key})) {
6537: $slotinfo{$which} = $remembered{$key};
6538: } else {
6539: %slotinfo=&get('slots',[$which],$cdom,$cnum);
6540: &Apache::lonhomework::showhash(%slotinfo);
6541: my ($tmp)=keys(%slotinfo);
6542: if ($tmp=~/^error:/) { return (); }
6543: $remembered{$key} = $slotinfo{$which};
6544: }
1.616 albertel 6545: if (ref($slotinfo{$which}) eq 'HASH') {
6546: return %{$slotinfo{$which}};
6547: }
6548: return $slotinfo{$which};
1.614 albertel 6549: }
1.31 www 6550: # ------------------------------------------------- Update symbolic store links
6551:
6552: sub symblist {
6553: my ($mapname,%newhash)=@_;
1.438 www 6554: $mapname=&deversion(&declutter($mapname));
1.31 www 6555: my %hash;
1.620 albertel 6556: if (($env{'request.course.fn'}) && (%newhash)) {
6557: if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
1.256 albertel 6558: &GDBM_WRCREAT(),0640)) {
1.711 albertel 6559: foreach my $url (keys %newhash) {
6560: next if ($url eq 'last_known'
6561: && $env{'form.no_update_last_known'});
6562: $hash{declutter($url)}=&encode_symb($mapname,
6563: $newhash{$url}->[1],
6564: $newhash{$url}->[0]);
1.191 harris41 6565: }
1.31 www 6566: if (untie(%hash)) {
6567: return 'ok';
6568: }
6569: }
6570: }
6571: return 'error';
1.212 www 6572: }
6573:
6574: # --------------------------------------------------------------- Verify a symb
6575:
6576: sub symbverify {
1.510 www 6577: my ($symb,$thisurl)=@_;
6578: my $thisfn=$thisurl;
1.439 www 6579: $thisfn=&declutter($thisfn);
1.215 www 6580: # direct jump to resource in page or to a sequence - will construct own symbs
6581: if ($thisfn=~/\.(page|sequence)$/) { return 1; }
6582: # check URL part
1.409 www 6583: my ($map,$resid,$url)=&decode_symb($symb);
1.439 www 6584:
1.431 www 6585: unless ($url eq $thisfn) { return 0; }
1.213 www 6586:
1.216 www 6587: $symb=&symbclean($symb);
1.510 www 6588: $thisurl=&deversion($thisurl);
1.439 www 6589: $thisfn=&deversion($thisfn);
1.213 www 6590:
6591: my %bighash;
6592: my $okay=0;
1.431 www 6593:
1.620 albertel 6594: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.256 albertel 6595: &GDBM_READER(),0640)) {
1.510 www 6596: my $ids=$bighash{'ids_'.&clutter($thisurl)};
1.216 www 6597: unless ($ids) {
1.510 www 6598: $ids=$bighash{'ids_/'.$thisurl};
1.216 www 6599: }
6600: if ($ids) {
6601: # ------------------------------------------------------------------- Has ID(s)
1.800 albertel 6602: foreach my $id (split(/\,/,$ids)) {
6603: my ($mapid,$resid)=split(/\./,$id);
1.216 www 6604: if (
6605: &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
6606: eq $symb) {
1.620 albertel 6607: if (($env{'request.role.adv'}) ||
1.800 albertel 6608: $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
1.582 albertel 6609: $okay=1;
6610: }
6611: }
1.216 www 6612: }
6613: }
1.213 www 6614: untie(%bighash);
6615: }
6616: return $okay;
1.31 www 6617: }
6618:
1.210 www 6619: # --------------------------------------------------------------- Clean-up symb
6620:
6621: sub symbclean {
6622: my $symb=shift;
1.568 albertel 6623: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
1.210 www 6624: # remove version from map
6625: $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
1.215 www 6626:
1.210 www 6627: # remove version from URL
6628: $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
1.213 www 6629:
1.507 www 6630: # remove wrapper
6631:
1.510 www 6632: $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
1.694 albertel 6633: $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
1.210 www 6634: return $symb;
1.409 www 6635: }
6636:
6637: # ---------------------------------------------- Split symb to find map and url
1.429 albertel 6638:
6639: sub encode_symb {
6640: my ($map,$resid,$url)=@_;
6641: return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
6642: }
1.409 www 6643:
6644: sub decode_symb {
1.568 albertel 6645: my $symb=shift;
6646: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
6647: my ($map,$resid,$url)=split(/___/,$symb);
1.413 www 6648: return (&fixversion($map),$resid,&fixversion($url));
6649: }
6650:
6651: sub fixversion {
6652: my $fn=shift;
1.609 banghart 6653: if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
1.435 www 6654: my %bighash;
6655: my $uri=&clutter($fn);
1.620 albertel 6656: my $key=$env{'request.course.id'}.'_'.$uri;
1.440 www 6657: # is this cached?
1.599 albertel 6658: my ($result,$cached)=&is_cached_new('courseresversion',$key);
1.440 www 6659: if (defined($cached)) { return $result; }
6660: # unfortunately not cached, or expired
1.620 albertel 6661: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.440 www 6662: &GDBM_READER(),0640)) {
6663: if ($bighash{'version_'.$uri}) {
6664: my $version=$bighash{'version_'.$uri};
1.444 www 6665: unless (($version eq 'mostrecent') ||
6666: ($version==&getversion($uri))) {
1.440 www 6667: $uri=~s/\.(\w+)$/\.$version\.$1/;
6668: }
6669: }
6670: untie %bighash;
1.413 www 6671: }
1.599 albertel 6672: return &do_cache_new('courseresversion',$key,&declutter($uri),600);
1.438 www 6673: }
6674:
6675: sub deversion {
6676: my $url=shift;
6677: $url=~s/\.\d+\.(\w+)$/\.$1/;
6678: return $url;
1.210 www 6679: }
6680:
1.31 www 6681: # ------------------------------------------------------ Return symb list entry
6682:
6683: sub symbread {
1.249 www 6684: my ($thisfn,$donotrecurse)=@_;
1.542 albertel 6685: my $cache_str='request.symbread.cached.'.$thisfn;
1.620 albertel 6686: if (defined($env{$cache_str})) { return $env{$cache_str}; }
1.242 www 6687: # no filename provided? try from environment
1.44 www 6688: unless ($thisfn) {
1.620 albertel 6689: if ($env{'request.symb'}) {
6690: return $env{$cache_str}=&symbclean($env{'request.symb'});
1.539 albertel 6691: }
1.620 albertel 6692: $thisfn=$env{'request.filename'};
1.44 www 6693: }
1.569 albertel 6694: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
1.242 www 6695: # is that filename actually a symb? Verify, clean, and return
6696: if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
1.539 albertel 6697: if (&symbverify($thisfn,$1)) {
1.620 albertel 6698: return $env{$cache_str}=&symbclean($thisfn);
1.539 albertel 6699: }
1.242 www 6700: }
1.44 www 6701: $thisfn=declutter($thisfn);
1.31 www 6702: my %hash;
1.37 www 6703: my %bighash;
6704: my $syval='';
1.620 albertel 6705: if (($env{'request.course.fn'}) && ($thisfn)) {
1.481 raeburn 6706: my $targetfn = $thisfn;
1.609 banghart 6707: if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
1.481 raeburn 6708: $targetfn = 'adm/wrapper/'.$thisfn;
6709: }
1.687 albertel 6710: if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
6711: $targetfn=$1;
6712: }
1.620 albertel 6713: if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
1.256 albertel 6714: &GDBM_READER(),0640)) {
1.481 raeburn 6715: $syval=$hash{$targetfn};
1.37 www 6716: untie(%hash);
6717: }
6718: # ---------------------------------------------------------- There was an entry
6719: if ($syval) {
1.601 albertel 6720: #unless ($syval=~/\_\d+$/) {
1.620 albertel 6721: #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.601 albertel 6722: #&appenv('request.ambiguous' => $thisfn);
1.620 albertel 6723: #return $env{$cache_str}='';
1.601 albertel 6724: #}
6725: #$syval.=$1;
6726: #}
1.37 www 6727: } else {
6728: # ------------------------------------------------------- Was not in symb table
1.620 albertel 6729: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.256 albertel 6730: &GDBM_READER(),0640)) {
1.37 www 6731: # ---------------------------------------------- Get ID(s) for current resource
1.280 www 6732: my $ids=$bighash{'ids_'.&clutter($thisfn)};
1.65 www 6733: unless ($ids) {
6734: $ids=$bighash{'ids_/'.$thisfn};
1.242 www 6735: }
6736: unless ($ids) {
6737: # alias?
6738: $ids=$bighash{'mapalias_'.$thisfn};
1.65 www 6739: }
1.37 www 6740: if ($ids) {
6741: # ------------------------------------------------------------------- Has ID(s)
6742: my @possibilities=split(/\,/,$ids);
1.39 www 6743: if ($#possibilities==0) {
6744: # ----------------------------------------------- There is only one possibility
1.37 www 6745: my ($mapid,$resid)=split(/\./,$ids);
1.626 albertel 6746: $syval=&encode_symb($bighash{'map_id_'.$mapid},
6747: $resid,$thisfn);
1.249 www 6748: } elsif (!$donotrecurse) {
1.39 www 6749: # ------------------------------------------ There is more than one possibility
6750: my $realpossible=0;
1.800 albertel 6751: foreach my $id (@possibilities) {
6752: my $file=$bighash{'src_'.$id};
1.39 www 6753: if (&allowed('bre',$file)) {
1.800 albertel 6754: my ($mapid,$resid)=split(/\./,$id);
1.39 www 6755: if ($bighash{'map_type_'.$mapid} ne 'page') {
6756: $realpossible++;
1.626 albertel 6757: $syval=&encode_symb($bighash{'map_id_'.$mapid},
6758: $resid,$thisfn);
1.39 www 6759: }
6760: }
1.191 harris41 6761: }
1.39 www 6762: if ($realpossible!=1) { $syval=''; }
1.249 www 6763: } else {
6764: $syval='';
1.37 www 6765: }
6766: }
6767: untie(%bighash)
1.481 raeburn 6768: }
1.31 www 6769: }
1.62 www 6770: if ($syval) {
1.620 albertel 6771: return $env{$cache_str}=$syval;
1.62 www 6772: }
1.31 www 6773: }
1.44 www 6774: &appenv('request.ambiguous' => $thisfn);
1.620 albertel 6775: return $env{$cache_str}='';
1.31 www 6776: }
6777:
6778: # ---------------------------------------------------------- Return random seed
6779:
1.32 www 6780: sub numval {
6781: my $txt=shift;
6782: $txt=~tr/A-J/0-9/;
6783: $txt=~tr/a-j/0-9/;
6784: $txt=~tr/K-T/0-9/;
6785: $txt=~tr/k-t/0-9/;
6786: $txt=~tr/U-Z/0-5/;
6787: $txt=~tr/u-z/0-5/;
6788: $txt=~s/\D//g;
1.564 albertel 6789: if ($_64bit) { if ($txt > 2**32) { return -1; } }
1.32 www 6790: return int($txt);
1.368 albertel 6791: }
6792:
1.484 albertel 6793: sub numval2 {
6794: my $txt=shift;
6795: $txt=~tr/A-J/0-9/;
6796: $txt=~tr/a-j/0-9/;
6797: $txt=~tr/K-T/0-9/;
6798: $txt=~tr/k-t/0-9/;
6799: $txt=~tr/U-Z/0-5/;
6800: $txt=~tr/u-z/0-5/;
6801: $txt=~s/\D//g;
6802: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
6803: my $total;
6804: foreach my $val (@txts) { $total+=$val; }
1.564 albertel 6805: if ($_64bit) { if ($total > 2**32) { return -1; } }
1.484 albertel 6806: return int($total);
6807: }
6808:
1.575 albertel 6809: sub numval3 {
6810: use integer;
6811: my $txt=shift;
6812: $txt=~tr/A-J/0-9/;
6813: $txt=~tr/a-j/0-9/;
6814: $txt=~tr/K-T/0-9/;
6815: $txt=~tr/k-t/0-9/;
6816: $txt=~tr/U-Z/0-5/;
6817: $txt=~tr/u-z/0-5/;
6818: $txt=~s/\D//g;
6819: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
6820: my $total;
6821: foreach my $val (@txts) { $total+=$val; }
6822: if ($_64bit) { $total=(($total<<32)>>32); }
6823: return $total;
6824: }
6825:
1.675 albertel 6826: sub digest {
6827: my ($data)=@_;
6828: my $digest=&Digest::MD5::md5($data);
6829: my ($a,$b,$c,$d)=unpack("iiii",$digest);
6830: my ($e,$f);
6831: {
6832: use integer;
6833: $e=($a+$b);
6834: $f=($c+$d);
6835: if ($_64bit) {
6836: $e=(($e<<32)>>32);
6837: $f=(($f<<32)>>32);
6838: }
6839: }
6840: if (wantarray) {
6841: return ($e,$f);
6842: } else {
6843: my $g;
6844: {
6845: use integer;
6846: $g=($e+$f);
6847: if ($_64bit) {
6848: $g=(($g<<32)>>32);
6849: }
6850: }
6851: return $g;
6852: }
6853: }
6854:
1.368 albertel 6855: sub latest_rnd_algorithm_id {
1.675 albertel 6856: return '64bit5';
1.366 albertel 6857: }
1.32 www 6858:
1.503 albertel 6859: sub get_rand_alg {
6860: my ($courseid)=@_;
1.790 albertel 6861: if (!$courseid) { $courseid=(&whichuser())[1]; }
1.503 albertel 6862: if ($courseid) {
1.620 albertel 6863: return $env{"course.$courseid.rndseed"};
1.503 albertel 6864: }
6865: return &latest_rnd_algorithm_id();
6866: }
6867:
1.562 albertel 6868: sub validCODE {
6869: my ($CODE)=@_;
6870: if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
6871: return 0;
6872: }
6873:
1.491 albertel 6874: sub getCODE {
1.620 albertel 6875: if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; }
1.618 albertel 6876: if ( (defined($Apache::lonhomework::parsing_a_problem) ||
6877: defined($Apache::lonhomework::parsing_a_task) ) &&
6878: &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
1.491 albertel 6879: return $Apache::lonhomework::history{'resource.CODE'};
6880: }
6881: return undef;
6882: }
6883:
1.31 www 6884: sub rndseed {
1.155 albertel 6885: my ($symb,$courseid,$domain,$username)=@_;
1.366 albertel 6886:
1.790 albertel 6887: my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
1.155 albertel 6888: if (!$symb) {
1.366 albertel 6889: unless ($symb=$wsymb) { return time; }
6890: }
6891: if (!$courseid) { $courseid=$wcourseid; }
6892: if (!$domain) { $domain=$wdomain; }
6893: if (!$username) { $username=$wusername }
1.503 albertel 6894: my $which=&get_rand_alg();
1.803 albertel 6895:
1.491 albertel 6896: if (defined(&getCODE())) {
1.675 albertel 6897: if ($which eq '64bit5') {
6898: return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
6899: } elsif ($which eq '64bit4') {
1.575 albertel 6900: return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
6901: } else {
6902: return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
6903: }
1.675 albertel 6904: } elsif ($which eq '64bit5') {
6905: return &rndseed_64bit5($symb,$courseid,$domain,$username);
1.575 albertel 6906: } elsif ($which eq '64bit4') {
6907: return &rndseed_64bit4($symb,$courseid,$domain,$username);
1.501 albertel 6908: } elsif ($which eq '64bit3') {
6909: return &rndseed_64bit3($symb,$courseid,$domain,$username);
1.443 albertel 6910: } elsif ($which eq '64bit2') {
6911: return &rndseed_64bit2($symb,$courseid,$domain,$username);
1.366 albertel 6912: } elsif ($which eq '64bit') {
6913: return &rndseed_64bit($symb,$courseid,$domain,$username);
6914: }
6915: return &rndseed_32bit($symb,$courseid,$domain,$username);
6916: }
6917:
6918: sub rndseed_32bit {
6919: my ($symb,$courseid,$domain,$username)=@_;
6920: {
6921: use integer;
6922: my $symbchck=unpack("%32C*",$symb) << 27;
6923: my $symbseed=numval($symb) << 22;
6924: my $namechck=unpack("%32C*",$username) << 17;
6925: my $nameseed=numval($username) << 12;
6926: my $domainseed=unpack("%32C*",$domain) << 7;
6927: my $courseseed=unpack("%32C*",$courseid);
6928: my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
1.790 albertel 6929: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6930: #&logthis("rndseed :$num:$symb");
1.564 albertel 6931: if ($_64bit) { $num=(($num<<32)>>32); }
1.366 albertel 6932: return $num;
6933: }
6934: }
6935:
6936: sub rndseed_64bit {
6937: my ($symb,$courseid,$domain,$username)=@_;
6938: {
6939: use integer;
6940: my $symbchck=unpack("%32S*",$symb) << 21;
6941: my $symbseed=numval($symb) << 10;
6942: my $namechck=unpack("%32S*",$username);
6943:
6944: my $nameseed=numval($username) << 21;
6945: my $domainseed=unpack("%32S*",$domain) << 10;
6946: my $courseseed=unpack("%32S*",$courseid);
6947:
6948: my $num1=$symbchck+$symbseed+$namechck;
6949: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 6950: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6951: #&logthis("rndseed :$num:$symb");
1.564 albertel 6952: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
1.366 albertel 6953: return "$num1,$num2";
1.155 albertel 6954: }
1.366 albertel 6955: }
6956:
1.443 albertel 6957: sub rndseed_64bit2 {
6958: my ($symb,$courseid,$domain,$username)=@_;
6959: {
6960: use integer;
6961: # strings need to be an even # of cahracters long, it it is odd the
6962: # last characters gets thrown away
6963: my $symbchck=unpack("%32S*",$symb.' ') << 21;
6964: my $symbseed=numval($symb) << 10;
6965: my $namechck=unpack("%32S*",$username.' ');
6966:
6967: my $nameseed=numval($username) << 21;
1.501 albertel 6968: my $domainseed=unpack("%32S*",$domain.' ') << 10;
6969: my $courseseed=unpack("%32S*",$courseid.' ');
6970:
6971: my $num1=$symbchck+$symbseed+$namechck;
6972: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 6973: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6974: #&logthis("rndseed :$num:$symb");
1.803 albertel 6975: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
1.501 albertel 6976: return "$num1,$num2";
6977: }
6978: }
6979:
6980: sub rndseed_64bit3 {
6981: my ($symb,$courseid,$domain,$username)=@_;
6982: {
6983: use integer;
6984: # strings need to be an even # of cahracters long, it it is odd the
6985: # last characters gets thrown away
6986: my $symbchck=unpack("%32S*",$symb.' ') << 21;
6987: my $symbseed=numval2($symb) << 10;
6988: my $namechck=unpack("%32S*",$username.' ');
6989:
6990: my $nameseed=numval2($username) << 21;
1.443 albertel 6991: my $domainseed=unpack("%32S*",$domain.' ') << 10;
6992: my $courseseed=unpack("%32S*",$courseid.' ');
6993:
6994: my $num1=$symbchck+$symbseed+$namechck;
6995: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 6996: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6997: #&logthis("rndseed :$num1:$num2:$_64bit");
1.564 albertel 6998: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
6999:
1.503 albertel 7000: return "$num1:$num2";
1.443 albertel 7001: }
7002: }
7003:
1.575 albertel 7004: sub rndseed_64bit4 {
7005: my ($symb,$courseid,$domain,$username)=@_;
7006: {
7007: use integer;
7008: # strings need to be an even # of cahracters long, it it is odd the
7009: # last characters gets thrown away
7010: my $symbchck=unpack("%32S*",$symb.' ') << 21;
7011: my $symbseed=numval3($symb) << 10;
7012: my $namechck=unpack("%32S*",$username.' ');
7013:
7014: my $nameseed=numval3($username) << 21;
7015: my $domainseed=unpack("%32S*",$domain.' ') << 10;
7016: my $courseseed=unpack("%32S*",$courseid.' ');
7017:
7018: my $num1=$symbchck+$symbseed+$namechck;
7019: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 7020: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
7021: #&logthis("rndseed :$num1:$num2:$_64bit");
1.575 albertel 7022: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
7023:
7024: return "$num1:$num2";
7025: }
7026: }
7027:
1.675 albertel 7028: sub rndseed_64bit5 {
7029: my ($symb,$courseid,$domain,$username)=@_;
7030: my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
7031: return "$num1:$num2";
7032: }
7033:
1.366 albertel 7034: sub rndseed_CODE_64bit {
7035: my ($symb,$courseid,$domain,$username)=@_;
1.155 albertel 7036: {
1.366 albertel 7037: use integer;
1.443 albertel 7038: my $symbchck=unpack("%32S*",$symb.' ') << 16;
1.484 albertel 7039: my $symbseed=numval2($symb);
1.491 albertel 7040: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
7041: my $CODEseed=numval(&getCODE());
1.443 albertel 7042: my $courseseed=unpack("%32S*",$courseid.' ');
1.484 albertel 7043: my $num1=$symbseed+$CODEchck;
7044: my $num2=$CODEseed+$courseseed+$symbchck;
1.790 albertel 7045: #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
7046: #&logthis("rndseed :$num1:$num2:$symb");
1.564 albertel 7047: if ($_64bit) { $num1=(($num1<<32)>>32); }
7048: if ($_64bit) { $num2=(($num2<<32)>>32); }
1.503 albertel 7049: return "$num1:$num2";
1.366 albertel 7050: }
7051: }
7052:
1.575 albertel 7053: sub rndseed_CODE_64bit4 {
7054: my ($symb,$courseid,$domain,$username)=@_;
7055: {
7056: use integer;
7057: my $symbchck=unpack("%32S*",$symb.' ') << 16;
7058: my $symbseed=numval3($symb);
7059: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
7060: my $CODEseed=numval3(&getCODE());
7061: my $courseseed=unpack("%32S*",$courseid.' ');
7062: my $num1=$symbseed+$CODEchck;
7063: my $num2=$CODEseed+$courseseed+$symbchck;
1.790 albertel 7064: #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
7065: #&logthis("rndseed :$num1:$num2:$symb");
1.575 albertel 7066: if ($_64bit) { $num1=(($num1<<32)>>32); }
7067: if ($_64bit) { $num2=(($num2<<32)>>32); }
7068: return "$num1:$num2";
7069: }
7070: }
7071:
1.675 albertel 7072: sub rndseed_CODE_64bit5 {
7073: my ($symb,$courseid,$domain,$username)=@_;
7074: my $code = &getCODE();
7075: my ($num1,$num2)=&digest("$symb,$courseid,$code");
7076: return "$num1:$num2";
7077: }
7078:
1.366 albertel 7079: sub setup_random_from_rndseed {
7080: my ($rndseed)=@_;
1.503 albertel 7081: if ($rndseed =~/([,:])/) {
7082: my ($num1,$num2)=split(/[,:]/,$rndseed);
1.366 albertel 7083: &Math::Random::random_set_seed(abs($num1),abs($num2));
7084: } else {
7085: &Math::Random::random_set_seed_from_phrase($rndseed);
1.98 albertel 7086: }
1.36 albertel 7087: }
7088:
1.474 albertel 7089: sub latest_receipt_algorithm_id {
7090: return 'receipt2';
7091: }
7092:
1.480 www 7093: sub recunique {
7094: my $fucourseid=shift;
7095: my $unique;
1.620 albertel 7096: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
7097: $unique=$env{"course.$fucourseid.internal.encseed"};
1.480 www 7098: } else {
7099: $unique=$perlvar{'lonReceipt'};
7100: }
7101: return unpack("%32C*",$unique);
7102: }
7103:
7104: sub recprefix {
7105: my $fucourseid=shift;
7106: my $prefix;
1.620 albertel 7107: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
7108: $prefix=$env{"course.$fucourseid.internal.encpref"};
1.480 www 7109: } else {
7110: $prefix=$perlvar{'lonHostID'};
7111: }
7112: return unpack("%32C*",$prefix);
7113: }
7114:
1.76 www 7115: sub ireceipt {
1.474 albertel 7116: my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
1.76 www 7117: my $cuname=unpack("%32C*",$funame);
7118: my $cudom=unpack("%32C*",$fudom);
7119: my $cucourseid=unpack("%32C*",$fucourseid);
7120: my $cusymb=unpack("%32C*",$fusymb);
1.480 www 7121: my $cunique=&recunique($fucourseid);
1.474 albertel 7122: my $cpart=unpack("%32S*",$part);
1.480 www 7123: my $return =&recprefix($fucourseid).'-';
1.620 albertel 7124: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
7125: $env{'request.state'} eq 'construct') {
1.790 albertel 7126: #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
1.474 albertel 7127:
7128: $return.= ($cunique%$cuname+
7129: $cunique%$cudom+
7130: $cusymb%$cuname+
7131: $cusymb%$cudom+
7132: $cucourseid%$cuname+
7133: $cucourseid%$cudom+
7134: $cpart%$cuname+
7135: $cpart%$cudom);
7136: } else {
7137: $return.= ($cunique%$cuname+
7138: $cunique%$cudom+
7139: $cusymb%$cuname+
7140: $cusymb%$cudom+
7141: $cucourseid%$cuname+
7142: $cucourseid%$cudom);
7143: }
7144: return $return;
1.76 www 7145: }
7146:
7147: sub receipt {
1.474 albertel 7148: my ($part)=@_;
1.790 albertel 7149: my ($symb,$courseid,$domain,$name) = &whichuser();
1.474 albertel 7150: return &ireceipt($name,$domain,$courseid,$symb,$part);
1.76 www 7151: }
1.260 ng 7152:
1.790 albertel 7153: sub whichuser {
7154: my ($passedsymb)=@_;
7155: my ($symb,$courseid,$domain,$name,$publicuser);
7156: if (defined($env{'form.grade_symb'})) {
7157: my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
7158: my $allowed=&allowed('vgr',$tmp_courseid);
7159: if (!$allowed &&
7160: exists($env{'request.course.sec'}) &&
7161: $env{'request.course.sec'} !~ /^\s*$/) {
7162: $allowed=&allowed('vgr',$tmp_courseid.
7163: '/'.$env{'request.course.sec'});
7164: }
7165: if ($allowed) {
7166: ($symb)=&get_env_multiple('form.grade_symb');
7167: $courseid=$tmp_courseid;
7168: ($domain)=&get_env_multiple('form.grade_domain');
7169: ($name)=&get_env_multiple('form.grade_username');
7170: return ($symb,$courseid,$domain,$name,$publicuser);
7171: }
7172: }
7173: if (!$passedsymb) {
7174: $symb=&symbread();
7175: } else {
7176: $symb=$passedsymb;
7177: }
7178: $courseid=$env{'request.course.id'};
7179: $domain=$env{'user.domain'};
7180: $name=$env{'user.name'};
7181: if ($name eq 'public' && $domain eq 'public') {
7182: if (!defined($env{'form.username'})) {
7183: $env{'form.username'}.=time.rand(10000000);
7184: }
7185: $name.=$env{'form.username'};
7186: }
7187: return ($symb,$courseid,$domain,$name,$publicuser);
7188:
7189: }
7190:
1.36 albertel 7191: # ------------------------------------------------------------ Serves up a file
1.472 albertel 7192: # returns either the contents of the file or
7193: # -1 if the file doesn't exist
1.481 raeburn 7194: #
7195: # if the target is a file that was uploaded via DOCS,
7196: # a check will be made to see if a current copy exists on the local server,
7197: # if it does this will be served, otherwise a copy will be retrieved from
7198: # the home server for the course and stored in /home/httpd/html/userfiles on
7199: # the local server.
1.472 albertel 7200:
1.36 albertel 7201: sub getfile {
1.538 albertel 7202: my ($file) = @_;
1.609 banghart 7203: if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
1.538 albertel 7204: &repcopy($file);
7205: return &readfile($file);
7206: }
7207:
7208: sub repcopy_userfile {
7209: my ($file)=@_;
1.609 banghart 7210: if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
1.610 albertel 7211: if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
1.538 albertel 7212: my ($cdom,$cnum,$filename) =
1.811 albertel 7213: ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
1.538 albertel 7214: my $uri="/uploaded/$cdom/$cnum/$filename";
7215: if (-e "$file") {
1.828 www 7216: # we already have a local copy, check it out
1.538 albertel 7217: my @fileinfo = stat($file);
1.828 www 7218: my $rtncode;
7219: my $info;
1.538 albertel 7220: my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
1.482 albertel 7221: if ($lwpresp ne 'ok') {
1.828 www 7222: # there is no such file anymore, even though we had a local copy
1.482 albertel 7223: if ($rtncode eq '404') {
1.538 albertel 7224: unlink($file);
1.482 albertel 7225: }
7226: return -1;
7227: }
7228: if ($info < $fileinfo[9]) {
1.828 www 7229: # nice, the file we have is up-to-date, just say okay
1.607 raeburn 7230: return 'ok';
1.828 www 7231: } else {
7232: # the file is outdated, get rid of it
7233: unlink($file);
1.482 albertel 7234: }
1.828 www 7235: }
7236: # one way or the other, at this point, we don't have the file
7237: # construct the correct path for the file
7238: my @parts = ($cdom,$cnum);
7239: if ($filename =~ m|^(.+)/[^/]+$|) {
7240: push @parts, split(/\//,$1);
7241: }
7242: my $path = $perlvar{'lonDocRoot'}.'/userfiles';
7243: foreach my $part (@parts) {
7244: $path .= '/'.$part;
7245: if (!-e $path) {
7246: mkdir($path,0770);
1.482 albertel 7247: }
7248: }
1.828 www 7249: # now the path exists for sure
7250: # get a user agent
7251: my $ua=new LWP::UserAgent;
7252: my $transferfile=$file.'.in.transfer';
7253: # FIXME: this should flock
7254: if (-e $transferfile) { return 'ok'; }
7255: my $request;
7256: $uri=~s/^\///;
1.829 www 7257: $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
1.828 www 7258: my $response=$ua->request($request,$transferfile);
7259: # did it work?
7260: if ($response->is_error()) {
7261: unlink($transferfile);
7262: &logthis("Userfile repcopy failed for $uri");
7263: return -1;
7264: }
7265: # worked, rename the transfer file
7266: rename($transferfile,$file);
1.607 raeburn 7267: return 'ok';
1.481 raeburn 7268: }
7269:
1.517 albertel 7270: sub tokenwrapper {
7271: my $uri=shift;
1.552 albertel 7272: $uri=~s|^http\://([^/]+)||;
7273: $uri=~s|^/||;
1.620 albertel 7274: $env{'user.environment'}=~/\/([^\/]+)\.id/;
1.517 albertel 7275: my $token=$1;
1.552 albertel 7276: my (undef,$udom,$uname,$file)=split('/',$uri,4);
7277: if ($udom && $uname && $file) {
7278: $file=~s|(\?\.*)*$||;
1.620 albertel 7279: &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
1.552 albertel 7280: return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
1.517 albertel 7281: (($uri=~/\?/)?'&':'?').'token='.$token.
7282: '&tokenissued='.$perlvar{'lonHostID'};
7283: } else {
7284: return '/adm/notfound.html';
7285: }
7286: }
7287:
1.828 www 7288: # call with reqtype HEAD: get last modification time
7289: # call with reqtype GET: get the file contents
7290: # Do not call this with reqtype GET for large files! It loads everything into memory
7291: #
1.481 raeburn 7292: sub getuploaded {
7293: my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
7294: $uri=~s/^\///;
7295: $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
7296: my $ua=new LWP::UserAgent;
7297: my $request=new HTTP::Request($reqtype,$uri);
7298: my $response=$ua->request($request);
7299: $$rtncode = $response->code;
1.482 albertel 7300: if (! $response->is_success()) {
7301: return 'failed';
7302: }
7303: if ($reqtype eq 'HEAD') {
1.486 www 7304: $$info = &HTTP::Date::str2time( $response->header('Last-modified') );
1.482 albertel 7305: } elsif ($reqtype eq 'GET') {
7306: $$info = $response->content;
1.472 albertel 7307: }
1.482 albertel 7308: return 'ok';
1.36 albertel 7309: }
7310:
1.481 raeburn 7311: sub readfile {
7312: my $file = shift;
7313: if ( (! -e $file ) || ($file eq '') ) { return -1; };
7314: my $fh;
7315: open($fh,"<$file");
7316: my $a='';
1.800 albertel 7317: while (my $line = <$fh>) { $a .= $line; }
1.481 raeburn 7318: return $a;
7319: }
7320:
1.36 albertel 7321: sub filelocation {
1.590 banghart 7322: my ($dir,$file) = @_;
7323: my $location;
7324: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.700 albertel 7325:
7326: if ($file =~ m-^/adm/-) {
7327: $file=~s-^/adm/wrapper/-/-;
7328: $file=~s-^/adm/coursedocs/showdoc/-/-;
7329: }
1.590 banghart 7330: if ($file=~m:^/~:) { # is a contruction space reference
7331: $location = $file;
7332: $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.807 albertel 7333: } elsif ($file=~m{^/home/$match_username/public_html/}) {
1.649 albertel 7334: # is a correct contruction space reference
7335: $location = $file;
1.609 banghart 7336: } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
1.590 banghart 7337: my ($udom,$uname,$filename)=
1.811 albertel 7338: ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
1.590 banghart 7339: my $home=&homeserver($uname,$udom);
7340: my $is_me=0;
7341: my @ids=¤t_machine_ids();
7342: foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
7343: if ($is_me) {
1.740 www 7344: $location=&propath($udom,$uname).
1.590 banghart 7345: '/userfiles/'.$filename;
7346: } else {
7347: $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
7348: $udom.'/'.$uname.'/'.$filename;
7349: }
7350: } else {
7351: $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
7352: $file=~s:^/res/:/:;
7353: if ( !( $file =~ m:^/:) ) {
7354: $location = $dir. '/'.$file;
7355: } else {
7356: $location = '/home/httpd/html/res'.$file;
7357: }
1.59 albertel 7358: }
1.590 banghart 7359: $location=~s://+:/:g; # remove duplicate /
7360: while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
7361: while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
7362: return $location;
1.46 www 7363: }
1.36 albertel 7364:
1.46 www 7365: sub hreflocation {
7366: my ($dir,$file)=@_;
1.460 albertel 7367: unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
1.666 albertel 7368: $file=filelocation($dir,$file);
1.700 albertel 7369: } elsif ($file=~m-^/adm/-) {
7370: $file=~s-^/adm/wrapper/-/-;
7371: $file=~s-^/adm/coursedocs/showdoc/-/-;
1.666 albertel 7372: }
7373: if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
7374: $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
1.807 albertel 7375: } elsif ($file=~m-/home/($match_username)/public_html/-) {
7376: $file=~s-^/home/($match_username)/public_html/-/~$1/-;
1.666 albertel 7377: } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
1.811 albertel 7378: $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
1.666 albertel 7379: -/uploaded/$1/$2/-x;
1.46 www 7380: }
1.462 albertel 7381: return $file;
1.465 albertel 7382: }
7383:
7384: sub current_machine_domains {
7385: my $hostname=$hostname{$perlvar{'lonHostID'}};
7386: my @domains;
7387: while( my($id, $name) = each(%hostname)) {
1.467 matthew 7388: # &logthis("-$id-$name-$hostname-");
1.465 albertel 7389: if ($hostname eq $name) {
7390: push(@domains,$hostdom{$id});
7391: }
7392: }
7393: return @domains;
7394: }
7395:
7396: sub current_machine_ids {
7397: my $hostname=$hostname{$perlvar{'lonHostID'}};
7398: my @ids;
7399: while( my($id, $name) = each(%hostname)) {
1.467 matthew 7400: # &logthis("-$id-$name-$hostname-");
1.465 albertel 7401: if ($hostname eq $name) {
7402: push(@ids,$id);
7403: }
7404: }
7405: return @ids;
1.31 www 7406: }
7407:
1.824 raeburn 7408: sub additional_machine_domains {
7409: my @domains;
7410: open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
7411: while( my $line = <$fh>) {
7412: $line =~ s/\s//g;
7413: push(@domains,$line);
7414: }
7415: return @domains;
7416: }
7417:
7418: sub default_login_domain {
7419: my $domain = $perlvar{'lonDefDomain'};
7420: my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
7421: foreach my $posdom (¤t_machine_domains(),
7422: &additional_machine_domains()) {
7423: if (lc($posdom) eq lc($testdomain)) {
7424: $domain=$posdom;
7425: last;
7426: }
7427: }
7428: return $domain;
7429: }
7430:
1.31 www 7431: # ------------------------------------------------------------- Declutters URLs
7432:
7433: sub declutter {
7434: my $thisfn=shift;
1.569 albertel 7435: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
1.479 albertel 7436: $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
1.31 www 7437: $thisfn=~s/^\///;
1.697 albertel 7438: $thisfn=~s|^adm/wrapper/||;
7439: $thisfn=~s|^adm/coursedocs/showdoc/||;
1.31 www 7440: $thisfn=~s/^res\///;
1.235 www 7441: $thisfn=~s/\?.+$//;
1.268 www 7442: return $thisfn;
7443: }
7444:
7445: # ------------------------------------------------------------- Clutter up URLs
7446:
7447: sub clutter {
7448: my $thisfn='/'.&declutter(shift);
1.609 banghart 7449: unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) {
1.270 www 7450: $thisfn='/res'.$thisfn;
7451: }
1.694 albertel 7452: if ($thisfn !~m|/adm|) {
1.695 albertel 7453: if ($thisfn =~ m|/ext/|) {
1.694 albertel 7454: $thisfn='/adm/wrapper'.$thisfn;
1.695 albertel 7455: } else {
7456: my ($ext) = ($thisfn =~ /\.(\w+)$/);
7457: my $embstyle=&Apache::loncommon::fileembstyle($ext);
1.698 albertel 7458: if ($embstyle eq 'ssi'
7459: || ($embstyle eq 'hdn')
7460: || ($embstyle eq 'rat')
7461: || ($embstyle eq 'prv')
7462: || ($embstyle eq 'ign')) {
7463: #do nothing with these
7464: } elsif (($embstyle eq 'img')
1.695 albertel 7465: || ($embstyle eq 'emb')
7466: || ($embstyle eq 'wrp')) {
7467: $thisfn='/adm/wrapper'.$thisfn;
1.698 albertel 7468: } elsif ($embstyle eq 'unk'
7469: && $thisfn!~/\.(sequence|page)$/) {
1.695 albertel 7470: $thisfn='/adm/coursedocs/showdoc'.$thisfn;
1.698 albertel 7471: } else {
1.718 www 7472: # &logthis("Got a blank emb style");
1.695 albertel 7473: }
1.694 albertel 7474: }
7475: }
1.31 www 7476: return $thisfn;
1.12 www 7477: }
7478:
1.787 albertel 7479: sub clutter_with_no_wrapper {
7480: my $uri = &clutter(shift);
7481: if ($uri =~ m-^/adm/-) {
7482: $uri =~ s-^/adm/wrapper/-/-;
7483: $uri =~ s-^/adm/coursedocs/showdoc/-/-;
7484: }
7485: return $uri;
7486: }
7487:
1.557 albertel 7488: sub freeze_escape {
7489: my ($value)=@_;
7490: if (ref($value)) {
7491: $value=&nfreeze($value);
7492: return '__FROZEN__'.&escape($value);
7493: }
7494: return &escape($value);
7495: }
7496:
1.11 www 7497:
1.557 albertel 7498: sub thaw_unescape {
7499: my ($value)=@_;
7500: if ($value =~ /^__FROZEN__/) {
7501: substr($value,0,10,undef);
7502: $value=&unescape($value);
7503: return &thaw($value);
7504: }
7505: return &unescape($value);
7506: }
7507:
1.436 albertel 7508: sub correct_line_ends {
7509: my ($result)=@_;
7510: $$result =~s/\r\n/\n/mg;
7511: $$result =~s/\r/\n/mg;
1.415 albertel 7512: }
1.1 albertel 7513: # ================================================================ Main Program
7514:
1.184 www 7515: sub goodbye {
1.204 albertel 7516: &logthis("Starting Shut down");
1.443 albertel 7517: #not converted to using infrastruture and probably shouldn't be
1.599 albertel 7518: &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
1.443 albertel 7519: #converted
1.599 albertel 7520: # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
7521: &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
7522: # &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
7523: # &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
1.425 albertel 7524: #1.1 only
1.599 albertel 7525: # &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
7526: # &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
7527: # &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
7528: # &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
7529: &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
7530: &logthis(sprintf("%-20s is %s",'kicks',$kicks));
7531: &logthis(sprintf("%-20s is %s",'hits',$hits));
1.184 www 7532: &flushcourselogs();
7533: &logthis("Shutting down");
7534: }
7535:
1.179 www 7536: BEGIN {
1.228 harris41 7537: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
1.195 www 7538: unless ($readit) {
1.217 harris41 7539: {
1.781 raeburn 7540: my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
7541: %perlvar = (%perlvar,%{$configvars});
1.227 harris41 7542: }
1.1 albertel 7543:
1.327 albertel 7544: # ------------------------------------------------------------ Read domain file
7545: {
7546: %domaindescription = ();
7547: %domain_auth_def = ();
7548: %domain_auth_arg_def = ();
1.448 albertel 7549: my $fh;
7550: if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
1.800 albertel 7551: while (my $line = <$fh>) {
7552: next if ($line =~ /^(\#|\s*$)/);
1.390 matthew 7553: # next if /^\#/;
1.801 foxr 7554: chomp $line;
1.403 www 7555: my ($domain, $domain_description, $def_auth, $def_auth_arg,
1.800 albertel 7556: $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
1.403 www 7557: $domain_auth_def{$domain}=$def_auth;
1.327 albertel 7558: $domain_auth_arg_def{$domain}=$def_auth_arg;
1.403 www 7559: $domaindescription{$domain}=$domain_description;
7560: $domain_lang_def{$domain}=$def_lang;
7561: $domain_city{$domain}=$city;
7562: $domain_longi{$domain}=$longi;
7563: $domain_lati{$domain}=$lati;
1.685 raeburn 7564: $domain_primary{$domain}=$primary;
1.403 www 7565:
1.448 albertel 7566: # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
1.327 albertel 7567: # &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
1.448 albertel 7568: }
1.327 albertel 7569: }
1.448 albertel 7570: close ($fh);
1.327 albertel 7571: }
7572:
7573:
1.1 albertel 7574: # ------------------------------------------------------------- Read hosts file
7575: {
1.448 albertel 7576: open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
1.1 albertel 7577:
7578: while (my $configline=<$config>) {
1.303 matthew 7579: next if ($configline =~ /^(\#|\s*$)/);
1.154 www 7580: chomp($configline);
1.595 albertel 7581: my ($id,$domain,$role,$name)=split(/:/,$configline);
1.597 albertel 7582: $name=~s/\s//g;
1.595 albertel 7583: if ($id && $domain && $role && $name) {
1.252 albertel 7584: $hostname{$id}=$name;
7585: $hostdom{$id}=$domain;
7586: if ($role eq 'library') { $libserv{$id}=$name; }
1.245 www 7587: }
1.1 albertel 7588: }
1.448 albertel 7589: close($config);
1.619 albertel 7590: # FIXME: dev server don't want this, production servers _do_ want this
1.654 albertel 7591: #&get_iphost();
1.1 albertel 7592: }
7593:
1.598 albertel 7594: sub get_iphost {
7595: if (%iphost) { return %iphost; }
1.653 albertel 7596: my %name_to_ip;
1.598 albertel 7597: foreach my $id (keys(%hostname)) {
7598: my $name=$hostname{$id};
1.653 albertel 7599: my $ip;
7600: if (!exists($name_to_ip{$name})) {
7601: $ip = gethostbyname($name);
7602: if (!$ip || length($ip) ne 4) {
1.826 www 7603: &logthis("Skipping host $id name $name no IP found");
1.653 albertel 7604: next;
7605: }
7606: $ip=inet_ntoa($ip);
7607: $name_to_ip{$name} = $ip;
7608: } else {
7609: $ip = $name_to_ip{$name};
1.598 albertel 7610: }
7611: push(@{$iphost{$ip}},$id);
7612: }
7613: return %iphost;
7614: }
7615:
1.1 albertel 7616: # ------------------------------------------------------ Read spare server file
7617: {
1.448 albertel 7618: open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
1.1 albertel 7619:
7620: while (my $configline=<$config>) {
7621: chomp($configline);
1.284 matthew 7622: if ($configline) {
1.784 albertel 7623: my ($host,$type) = split(':',$configline,2);
1.785 albertel 7624: if (!defined($type) || $type eq '') { $type = 'default' };
1.784 albertel 7625: push(@{ $spareid{$type} }, $host);
1.1 albertel 7626: }
7627: }
1.448 albertel 7628: close($config);
1.1 albertel 7629: }
1.11 www 7630: # ------------------------------------------------------------ Read permissions
7631: {
1.448 albertel 7632: open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
1.11 www 7633:
7634: while (my $configline=<$config>) {
1.448 albertel 7635: chomp($configline);
7636: if ($configline) {
7637: my ($role,$perm)=split(/ /,$configline);
7638: if ($perm ne '') { $pr{$role}=$perm; }
7639: }
1.11 www 7640: }
1.448 albertel 7641: close($config);
1.11 www 7642: }
7643:
7644: # -------------------------------------------- Read plain texts for permissions
7645: {
1.448 albertel 7646: open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
1.11 www 7647:
7648: while (my $configline=<$config>) {
1.448 albertel 7649: chomp($configline);
7650: if ($configline) {
1.742 raeburn 7651: my ($short,@plain)=split(/:/,$configline);
7652: %{$prp{$short}} = ();
7653: if (@plain > 0) {
7654: $prp{$short}{'std'} = $plain[0];
7655: for (my $i=1; $i<@plain; $i++) {
7656: $prp{$short}{'alt'.$i} = $plain[$i];
7657: }
7658: }
1.448 albertel 7659: }
1.135 www 7660: }
1.448 albertel 7661: close($config);
1.135 www 7662: }
7663:
7664: # ---------------------------------------------------------- Read package table
7665: {
1.448 albertel 7666: open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
1.135 www 7667:
7668: while (my $configline=<$config>) {
1.483 albertel 7669: if ($configline !~ /\S/ || $configline=~/^#/) { next; }
1.448 albertel 7670: chomp($configline);
7671: my ($short,$plain)=split(/:/,$configline);
7672: my ($pack,$name)=split(/\&/,$short);
7673: if ($plain ne '') {
7674: $packagetab{$pack.'&'.$name.'&name'}=$name;
7675: $packagetab{$short}=$plain;
7676: }
1.11 www 7677: }
1.448 albertel 7678: close($config);
1.329 matthew 7679: }
7680:
7681: # ------------- set up temporary directory
7682: {
7683: $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
7684:
1.11 www 7685: }
7686:
1.794 albertel 7687: $memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
7688: 'compress_threshold'=> 20_000,
7689: });
1.185 www 7690:
1.281 www 7691: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
1.186 www 7692: $dumpcount=0;
1.22 www 7693:
1.163 harris41 7694: &logtouch();
1.672 albertel 7695: &logthis('<font color="yellow">INFO: Read configuration</font>');
1.195 www 7696: $readit=1;
1.564 albertel 7697: {
7698: use integer;
7699: my $test=(2**32)+1;
1.568 albertel 7700: if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
1.564 albertel 7701: &logthis(" Detected 64bit platform ($_64bit)");
7702: }
1.195 www 7703: }
1.1 albertel 7704: }
1.179 www 7705:
1.1 albertel 7706: 1;
1.191 harris41 7707: __END__
7708:
1.243 albertel 7709: =pod
7710:
1.191 harris41 7711: =head1 NAME
7712:
1.243 albertel 7713: Apache::lonnet - Subroutines to ask questions about things in the network.
1.191 harris41 7714:
7715: =head1 SYNOPSIS
7716:
1.243 albertel 7717: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
1.191 harris41 7718:
7719: &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
7720:
1.243 albertel 7721: Common parameters:
7722:
7723: =over 4
7724:
7725: =item *
7726:
7727: $uname : an internal username (if $cname expecting a course Id specifically)
7728:
7729: =item *
7730:
7731: $udom : a domain (if $cdom expecting a course's domain specifically)
7732:
7733: =item *
7734:
7735: $symb : a resource instance identifier
7736:
7737: =item *
7738:
7739: $namespace : the name of a .db file that contains the data needed or
7740: being set.
7741:
7742: =back
7743:
1.394 bowersj2 7744: =head1 OVERVIEW
1.191 harris41 7745:
1.394 bowersj2 7746: lonnet provides subroutines which interact with the
7747: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
7748: about classes, users, and resources.
1.243 albertel 7749:
7750: For many of these objects you can also use this to store data about
7751: them or modify them in various ways.
1.191 harris41 7752:
1.394 bowersj2 7753: =head2 Symbs
1.191 harris41 7754:
1.394 bowersj2 7755: To identify a specific instance of a resource, LON-CAPA uses symbols
7756: or "symbs"X<symb>. These identifiers are built from the URL of the
7757: map, the resource number of the resource in the map, and the URL of
7758: the resource itself. The latter is somewhat redundant, but might help
7759: if maps change.
7760:
7761: An example is
7762:
7763: msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
7764:
7765: The respective map entry is
7766:
7767: <resource id="19" src="/res/msu/korte/tests/part12.problem"
7768: title="Problem 2">
7769: </resource>
7770:
7771: Symbs are used by the random number generator, as well as to store and
7772: restore data specific to a certain instance of for example a problem.
7773:
7774: =head2 Storing And Retrieving Data
7775:
7776: X<store()>X<cstore()>X<restore()>Three of the most important functions
7777: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
7778: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
7779: is is the non-critical message twin of cstore. These functions are for
7780: handlers to store a perl hash to a user's permanent data space in an
7781: easy manner, and to retrieve it again on another call. It is expected
7782: that a handler would use this once at the beginning to retrieve data,
7783: and then again once at the end to send only the new data back.
7784:
7785: The data is stored in the user's data directory on the user's
7786: homeserver under the ID of the course.
7787:
7788: The hash that is returned by restore will have all of the previous
7789: value for all of the elements of the hash.
7790:
7791: Example:
7792:
7793: #creating a hash
7794: my %hash;
7795: $hash{'foo'}='bar';
7796:
7797: #storing it
7798: &Apache::lonnet::cstore(\%hash);
7799:
7800: #changing a value
7801: $hash{'foo'}='notbar';
7802:
7803: #adding a new value
7804: $hash{'bar'}='foo';
7805: &Apache::lonnet::cstore(\%hash);
7806:
7807: #retrieving the hash
7808: my %history=&Apache::lonnet::restore();
7809:
7810: #print the hash
7811: foreach my $key (sort(keys(%history))) {
7812: print("\%history{$key} = $history{$key}");
7813: }
7814:
7815: Will print out:
1.191 harris41 7816:
1.394 bowersj2 7817: %history{1:foo} = bar
7818: %history{1:keys} = foo:timestamp
7819: %history{1:timestamp} = 990455579
7820: %history{2:bar} = foo
7821: %history{2:foo} = notbar
7822: %history{2:keys} = foo:bar:timestamp
7823: %history{2:timestamp} = 990455580
7824: %history{bar} = foo
7825: %history{foo} = notbar
7826: %history{timestamp} = 990455580
7827: %history{version} = 2
7828:
7829: Note that the special hash entries C<keys>, C<version> and
7830: C<timestamp> were added to the hash. C<version> will be equal to the
7831: total number of versions of the data that have been stored. The
7832: C<timestamp> attribute will be the UNIX time the hash was
7833: stored. C<keys> is available in every historical section to list which
7834: keys were added or changed at a specific historical revision of a
7835: hash.
7836:
7837: B<Warning>: do not store the hash that restore returns directly. This
7838: will cause a mess since it will restore the historical keys as if the
7839: were new keys. I.E. 1:foo will become 1:1:foo etc.
1.191 harris41 7840:
1.394 bowersj2 7841: Calling convention:
1.191 harris41 7842:
1.394 bowersj2 7843: my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
7844: &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
1.191 harris41 7845:
1.394 bowersj2 7846: For more detailed information, see lonnet specific documentation.
1.191 harris41 7847:
1.394 bowersj2 7848: =head1 RETURN MESSAGES
1.191 harris41 7849:
1.394 bowersj2 7850: =over 4
1.191 harris41 7851:
1.394 bowersj2 7852: =item * B<con_lost>: unable to contact remote host
1.191 harris41 7853:
1.394 bowersj2 7854: =item * B<con_delayed>: unable to contact remote host, message will be delivered
7855: when the connection is brought back up
1.191 harris41 7856:
1.394 bowersj2 7857: =item * B<con_failed>: unable to contact remote host and unable to save message
7858: for later delivery
1.191 harris41 7859:
1.394 bowersj2 7860: =item * B<error:>: an error a occured, a description of the error follows the :
1.191 harris41 7861:
1.394 bowersj2 7862: =item * B<no_such_host>: unable to fund a host associated with the user/domain
1.243 albertel 7863: that was requested
1.191 harris41 7864:
1.243 albertel 7865: =back
1.191 harris41 7866:
1.243 albertel 7867: =head1 PUBLIC SUBROUTINES
1.191 harris41 7868:
1.243 albertel 7869: =head2 Session Environment Functions
1.191 harris41 7870:
1.243 albertel 7871: =over 4
1.191 harris41 7872:
1.394 bowersj2 7873: =item *
7874: X<appenv()>
7875: B<appenv(%hash)>: the value of %hash is written to
7876: the user envirnoment file, and will be restored for each access this
1.620 albertel 7877: user makes during this session, also modifies the %env for the current
1.394 bowersj2 7878: process
1.191 harris41 7879:
7880: =item *
1.394 bowersj2 7881: X<delenv()>
7882: B<delenv($regexp)>: removes all items from the session
7883: environment file that matches the regular expression in $regexp. The
1.620 albertel 7884: values are also delted from the current processes %env.
1.191 harris41 7885:
1.795 albertel 7886: =item * get_env_multiple($name)
7887:
7888: gets $name from the %env hash, it seemlessly handles the cases where multiple
7889: values may be defined and end up as an array ref.
7890:
7891: returns an array of values
7892:
1.243 albertel 7893: =back
7894:
7895: =head2 User Information
1.191 harris41 7896:
1.243 albertel 7897: =over 4
1.191 harris41 7898:
7899: =item *
1.394 bowersj2 7900: X<queryauthenticate()>
7901: B<queryauthenticate($uname,$udom)>: try to determine user's current
1.191 harris41 7902: authentication scheme
7903:
7904: =item *
1.394 bowersj2 7905: X<authenticate()>
7906: B<authenticate($uname,$upass,$udom)>: try to
7907: authenticate user from domain's lib servers (first use the current
7908: one). C<$upass> should be the users password.
1.191 harris41 7909:
7910: =item *
1.394 bowersj2 7911: X<homeserver()>
7912: B<homeserver($uname,$udom)>: find the server which has
7913: the user's directory and files (there must be only one), this caches
7914: the answer, and also caches if there is a borken connection.
1.191 harris41 7915:
7916: =item *
1.394 bowersj2 7917: X<idget()>
7918: B<idget($udom,@ids)>: find the usernames behind a list of IDs
7919: (IDs are a unique resource in a domain, there must be only 1 ID per
7920: username, and only 1 username per ID in a specific domain) (returns
7921: hash: id=>name,id=>name)
1.191 harris41 7922:
7923: =item *
1.394 bowersj2 7924: X<idrget()>
7925: B<idrget($udom,@unames)>: find the IDs behind a list of
7926: usernames (returns hash: name=>id,name=>id)
1.191 harris41 7927:
7928: =item *
1.394 bowersj2 7929: X<idput()>
7930: B<idput($udom,%ids)>: store away a list of names and associated IDs
1.191 harris41 7931:
7932: =item *
1.394 bowersj2 7933: X<rolesinit()>
7934: B<rolesinit($udom,$username,$authhost)>: get user privileges
1.243 albertel 7935:
7936: =item *
1.551 albertel 7937: X<getsection()>
7938: B<getsection($udom,$uname,$cname)>: finds the section of student in the
1.243 albertel 7939: course $cname, return section name/number or '' for "not in course"
7940: and '-1' for "no section"
7941:
7942: =item *
1.394 bowersj2 7943: X<userenvironment()>
7944: B<userenvironment($udom,$uname,@what)>: gets the values of the keys
1.243 albertel 7945: passed in @what from the requested user's environment, returns a hash
7946:
7947: =back
7948:
7949: =head2 User Roles
7950:
7951: =over 4
7952:
7953: =item *
7954:
1.810 raeburn 7955: allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
1.243 albertel 7956: F: full access
7957: U,I,K: authentication modes (cxx only)
7958: '': forbidden
7959: 1: user needs to choose course
7960: 2: browse allowed
1.766 albertel 7961: A: passphrase authentication needed
1.243 albertel 7962:
7963: =item *
7964:
7965: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
7966: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
7967: and course level
7968:
7969: =item *
7970:
7971: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
7972: explanation of a user role term
7973:
1.832 ! raeburn 7974: =item *
! 7975:
! 7976: get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional. Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles.
1.243 albertel 7977: =back
7978:
7979: =head2 User Modification
7980:
7981: =over 4
7982:
7983: =item *
7984:
7985: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
7986: user for the level given by URL. Optional start and end dates (leave empty
7987: string or zero for "no date")
1.191 harris41 7988:
7989: =item *
7990:
1.243 albertel 7991: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
7992: change a users, password, possible return values are: ok,
7993: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
7994: refused
1.191 harris41 7995:
7996: =item *
7997:
1.243 albertel 7998: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
1.191 harris41 7999:
8000: =item *
8001:
1.243 albertel 8002: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :
8003: modify user
1.191 harris41 8004:
8005: =item *
8006:
1.286 matthew 8007: modifystudent
8008:
8009: modify a students enrollment and identification information.
8010: The course id is resolved based on the current users environment.
8011: This means the envoking user must be a course coordinator or otherwise
8012: associated with a course.
8013:
1.297 matthew 8014: This call is essentially a wrapper for lonnet::modifyuser and
8015: lonnet::modify_student_enrollment
1.286 matthew 8016:
8017: Inputs:
8018:
8019: =over 4
8020:
8021: =item B<$udom> Students loncapa domain
8022:
8023: =item B<$uname> Students loncapa login name
8024:
8025: =item B<$uid> Students id/student number
8026:
8027: =item B<$umode> Students authentication mode
8028:
8029: =item B<$upass> Students password
8030:
8031: =item B<$first> Students first name
8032:
8033: =item B<$middle> Students middle name
8034:
8035: =item B<$last> Students last name
8036:
8037: =item B<$gene> Students generation
8038:
8039: =item B<$usec> Students section in course
8040:
8041: =item B<$end> Unix time of the roles expiration
8042:
8043: =item B<$start> Unix time of the roles start date
8044:
8045: =item B<$forceid> If defined, allow $uid to be changed
8046:
8047: =item B<$desiredhome> server to use as home server for student
8048:
8049: =back
1.297 matthew 8050:
8051: =item *
8052:
8053: modify_student_enrollment
8054:
8055: Change a students enrollment status in a class. The environment variable
8056: 'role.request.course' must be defined for this function to proceed.
8057:
8058: Inputs:
8059:
8060: =over 4
8061:
8062: =item $udom, students domain
8063:
8064: =item $uname, students name
8065:
8066: =item $uid, students user id
8067:
8068: =item $first, students first name
8069:
8070: =item $middle
8071:
8072: =item $last
8073:
8074: =item $gene
8075:
8076: =item $usec
8077:
8078: =item $end
8079:
8080: =item $start
8081:
8082: =back
8083:
1.191 harris41 8084:
8085: =item *
8086:
1.243 albertel 8087: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
8088: custom role; give a custom role to a user for the level given by URL. Specify
8089: name and domain of role author, and role name
1.191 harris41 8090:
8091: =item *
8092:
1.243 albertel 8093: revokerole($udom,$uname,$url,$role) : revoke a role for url
1.191 harris41 8094:
8095: =item *
8096:
1.243 albertel 8097: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
8098:
8099: =back
8100:
8101: =head2 Course Infomation
8102:
8103: =over 4
1.191 harris41 8104:
8105: =item *
8106:
1.631 albertel 8107: coursedescription($courseid) : returns a hash of information about the
8108: specified course id, including all environment settings for the
8109: course, the description of the course will be in the hash under the
8110: key 'description'
1.191 harris41 8111:
8112: =item *
8113:
1.624 albertel 8114: resdata($name,$domain,$type,@which) : request for current parameter
8115: setting for a specific $type, where $type is either 'course' or 'user',
8116: @what should be a list of parameters to ask about. This routine caches
8117: answers for 5 minutes.
1.243 albertel 8118:
8119: =back
8120:
8121: =head2 Course Modification
8122:
8123: =over 4
1.191 harris41 8124:
8125: =item *
8126:
1.243 albertel 8127: writecoursepref($courseid,%prefs) : write preferences (environment
8128: database) for a course
1.191 harris41 8129:
8130: =item *
8131:
1.243 albertel 8132: createcourse($udom,$description,$url) : make/modify course
8133:
8134: =back
8135:
8136: =head2 Resource Subroutines
8137:
8138: =over 4
1.191 harris41 8139:
8140: =item *
8141:
1.243 albertel 8142: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
1.191 harris41 8143:
8144: =item *
8145:
1.243 albertel 8146: repcopy($filename) : subscribes to the requested file, and attempts to
8147: replicate from the owning library server, Might return
1.607 raeburn 8148: 'unavailable', 'not_found', 'forbidden', 'ok', or
8149: 'bad_request', also attempts to grab the metadata for the
1.243 albertel 8150: resource. Expects the local filesystem pathname
8151: (/home/httpd/html/res/....)
8152:
8153: =back
8154:
8155: =head2 Resource Information
8156:
8157: =over 4
1.191 harris41 8158:
8159: =item *
8160:
1.243 albertel 8161: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
8162: a vairety of different possible values, $varname should be a request
8163: string, and the other parameters can be used to specify who and what
8164: one is asking about.
8165:
8166: Possible values for $varname are environment.lastname (or other item
8167: from the envirnment hash), user.name (or someother aspect about the
8168: user), resource.0.maxtries (or some other part and parameter of a
8169: resource)
1.204 albertel 8170:
8171: =item *
8172:
1.243 albertel 8173: directcondval($number) : get current value of a condition; reads from a state
8174: string
1.204 albertel 8175:
8176: =item *
8177:
1.243 albertel 8178: condval($condidx) : value of condition index based on state
1.204 albertel 8179:
8180: =item *
8181:
1.243 albertel 8182: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
8183: resource's metadata, $what should be either a specific key, or either
8184: 'keys' (to get a list of possible keys) or 'packages' to get a list of
8185: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
8186:
8187: this function automatically caches all requests
1.191 harris41 8188:
8189: =item *
8190:
1.243 albertel 8191: metadata_query($query,$custom,$customshow) : make a metadata query against the
8192: network of library servers; returns file handle of where SQL and regex results
8193: will be stored for query
1.191 harris41 8194:
8195: =item *
8196:
1.243 albertel 8197: symbread($filename) : return symbolic list entry (filename argument optional);
8198: returns the data handle
1.191 harris41 8199:
8200: =item *
8201:
1.243 albertel 8202: symbverify($symb,$thisfn) : verifies that $symb actually exists and is
1.582 albertel 8203: a possible symb for the URL in $thisfn, and if is an encryypted
8204: resource that the user accessed using /enc/ returns a 1 on success, 0
8205: on failure, user must be in a course, as it assumes the existance of
1.620 albertel 8206: the course initial hash, and uses $env('request.course.id'}
1.243 albertel 8207:
1.191 harris41 8208:
8209: =item *
8210:
1.243 albertel 8211: symbclean($symb) : removes versions numbers from a symb, returns the
8212: cleaned symb
1.191 harris41 8213:
8214: =item *
8215:
1.243 albertel 8216: is_on_map($uri) : checks if the $uri is somewhere on the current
8217: course map, user must be in a course for it to work.
1.191 harris41 8218:
8219: =item *
8220:
1.243 albertel 8221: numval($salt) : return random seed value (addend for rndseed)
1.191 harris41 8222:
8223: =item *
8224:
1.243 albertel 8225: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
8226: a random seed, all arguments are optional, if they aren't sent it uses the
8227: environment to derive them. Note: if symb isn't sent and it can't get one
8228: from &symbread it will use the current time as its return value
1.191 harris41 8229:
8230: =item *
8231:
1.243 albertel 8232: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
8233: unfakeable, receipt
1.191 harris41 8234:
8235: =item *
8236:
1.620 albertel 8237: receipt() : API to ireceipt working off of env values; given out to users
1.191 harris41 8238:
8239: =item *
8240:
1.243 albertel 8241: countacc($url) : count the number of accesses to a given URL
1.191 harris41 8242:
8243: =item *
8244:
1.243 albertel 8245: checkout($symb,$tuname,$tudom,$tcrsid) : creates a record of a user having looked at an item, most likely printed out or otherwise using a resource
1.191 harris41 8246:
8247: =item *
8248:
1.243 albertel 8249: checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid)
1.191 harris41 8250:
8251: =item *
8252:
1.243 albertel 8253: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
1.191 harris41 8254:
8255: =item *
8256:
1.243 albertel 8257: devalidate($symb) : devalidate temporary spreadsheet calculations,
8258: forcing spreadsheet to reevaluate the resource scores next time.
8259:
8260: =back
8261:
8262: =head2 Storing/Retreiving Data
8263:
8264: =over 4
1.191 harris41 8265:
8266: =item *
8267:
1.243 albertel 8268: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
8269: for this url; hashref needs to be given and should be a \%hashname; the
8270: remaining args aren't required and if they aren't passed or are '' they will
1.620 albertel 8271: be derived from the env
1.191 harris41 8272:
8273: =item *
8274:
1.243 albertel 8275: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
8276: uses critical subroutine
1.191 harris41 8277:
8278: =item *
8279:
1.243 albertel 8280: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
8281: all args are optional
1.191 harris41 8282:
8283: =item *
8284:
1.717 albertel 8285: dumpstore($namespace,$udom,$uname,$regexp,$range) :
8286: dumps the complete (or key matching regexp) namespace into a hash
8287: ($udom, $uname, $regexp, $range are optional) for a namespace that is
8288: normally &store()ed into
8289:
8290: $range should be either an integer '100' (give me the first 100
8291: matching records)
8292: or be two integers sperated by a - with no spaces
8293: '30-50' (give me the 30th through the 50th matching
8294: records)
8295:
8296:
8297: =item *
8298:
8299: putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
8300: replaces a &store() version of data with a replacement set of data
8301: for a particular resource in a namespace passed in the $storehash hash
8302: reference
8303:
8304: =item *
8305:
1.243 albertel 8306: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
8307: works very similar to store/cstore, but all data is stored in a
8308: temporary location and can be reset using tmpreset, $storehash should
8309: be a hash reference, returns nothing on success
1.191 harris41 8310:
8311: =item *
8312:
1.243 albertel 8313: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
8314: similar to restore, but all data is stored in a temporary location and
8315: can be reset using tmpreset. Returns a hash of values on success,
8316: error string otherwise.
1.191 harris41 8317:
8318: =item *
8319:
1.243 albertel 8320: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
8321: deltes all keys for $symb form the temporary storage hash.
1.191 harris41 8322:
8323: =item *
8324:
1.243 albertel 8325: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
8326: reference filled in from namesp ($udom and $uname are optional)
1.191 harris41 8327:
8328: =item *
8329:
1.243 albertel 8330: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
8331: namesp ($udom and $uname are optional)
1.191 harris41 8332:
8333: =item *
8334:
1.702 albertel 8335: dump($namespace,$udom,$uname,$regexp,$range) :
1.243 albertel 8336: dumps the complete (or key matching regexp) namespace into a hash
1.702 albertel 8337: ($udom, $uname, $regexp, $range are optional)
1.449 matthew 8338:
1.702 albertel 8339: $range should be either an integer '100' (give me the first 100
8340: matching records)
8341: or be two integers sperated by a - with no spaces
8342: '30-50' (give me the 30th through the 50th matching
8343: records)
1.449 matthew 8344: =item *
8345:
8346: inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
8347: $store can be a scalar, an array reference, or if the amount to be
8348: incremented is > 1, a hash reference.
8349:
8350: ($udom and $uname are optional)
1.191 harris41 8351:
8352: =item *
8353:
1.243 albertel 8354: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
8355: ($udom and $uname are optional)
1.191 harris41 8356:
8357: =item *
8358:
1.243 albertel 8359: cput($namespace,$storehash,$udom,$uname) : critical put
8360: ($udom and $uname are optional)
1.191 harris41 8361:
8362: =item *
8363:
1.748 albertel 8364: newput($namespace,$storehash,$udom,$uname) :
8365:
8366: Attempts to store the items in the $storehash, but only if they don't
8367: currently exist, if this succeeds you can be certain that you have
8368: successfully created a new key value pair in the $namespace db.
8369:
8370:
8371: Args:
8372: $namespace: name of database to store values to
8373: $storehash: hashref to store to the db
8374: $udom: (optional) domain of user containing the db
8375: $uname: (optional) name of user caontaining the db
8376:
8377: Returns:
8378: 'ok' -> succeeded in storing all keys of $storehash
8379: 'key_exists: <key>' -> failed to anything out of $storehash, as at
8380: least <key> already existed in the db (other
8381: requested keys may also already exist)
8382: 'error: <msg>' -> unable to tie the DB or other erorr occured
8383: 'con_lost' -> unable to contact request server
8384: 'refused' -> action was not allowed by remote machine
8385:
8386:
8387: =item *
8388:
1.243 albertel 8389: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
8390: reference filled in from namesp (encrypts the return communication)
8391: ($udom and $uname are optional)
1.191 harris41 8392:
8393: =item *
8394:
1.243 albertel 8395: log($udom,$name,$home,$message) : write to permanent log for user; use
8396: critical subroutine
8397:
1.806 raeburn 8398: =item *
8399:
8400: get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
8401: reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
8402:
8403: =item *
8404:
8405: put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)
8406:
1.243 albertel 8407: =back
8408:
8409: =head2 Network Status Functions
8410:
8411: =over 4
1.191 harris41 8412:
8413: =item *
8414:
8415: dirlist($uri) : return directory list based on URI
8416:
8417: =item *
8418:
1.243 albertel 8419: spareserver() : find server with least workload from spare.tab
8420:
8421: =back
8422:
8423: =head2 Apache Request
8424:
8425: =over 4
1.191 harris41 8426:
8427: =item *
8428:
1.243 albertel 8429: ssi($url,%hash) : server side include, does a complete request cycle on url to
8430: localhost, posts hash
8431:
8432: =back
8433:
8434: =head2 Data to String to Data
8435:
8436: =over 4
1.191 harris41 8437:
8438: =item *
8439:
1.243 albertel 8440: hash2str(%hash) : convert a hash into a string complete with escaping and '='
8441: and '&' separators, supports elements that are arrayrefs and hashrefs
1.191 harris41 8442:
8443: =item *
8444:
1.243 albertel 8445: hashref2str($hashref) : convert a hashref into a string complete with
8446: escaping and '=' and '&' separators, supports elements that are
8447: arrayrefs and hashrefs
1.191 harris41 8448:
8449: =item *
8450:
1.243 albertel 8451: arrayref2str($arrayref) : convert an arrayref into a string complete
8452: with escaping and '&' separators, supports elements that are arrayrefs
8453: and hashrefs
1.191 harris41 8454:
8455: =item *
8456:
1.243 albertel 8457: str2hash($string) : convert string to hash using unescaping and
8458: splitting on '=' and '&', supports elements that are arrayrefs and
8459: hashrefs
1.191 harris41 8460:
8461: =item *
8462:
1.243 albertel 8463: str2array($string) : convert string to hash using unescaping and
8464: splitting on '&', supports elements that are arrayrefs and hashrefs
8465:
8466: =back
8467:
8468: =head2 Logging Routines
8469:
8470: =over 4
8471:
8472: These routines allow one to make log messages in the lonnet.log and
8473: lonnet.perm logfiles.
1.191 harris41 8474:
8475: =item *
8476:
1.243 albertel 8477: logtouch() : make sure the logfile, lonnet.log, exists
1.191 harris41 8478:
8479: =item *
8480:
1.243 albertel 8481: logthis() : append message to the normal lonnet.log file, it gets
8482: preiodically rolled over and deleted.
1.191 harris41 8483:
8484: =item *
8485:
1.243 albertel 8486: logperm() : append a permanent message to lonnet.perm.log, this log
8487: file never gets deleted by any automated portion of the system, only
8488: messages of critical importance should go in here.
8489:
8490: =back
8491:
8492: =head2 General File Helper Routines
8493:
8494: =over 4
1.191 harris41 8495:
8496: =item *
8497:
1.481 raeburn 8498: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
8499: (a) files in /uploaded
8500: (i) If a local copy of the file exists -
8501: compares modification date of local copy with last-modified date for
8502: definitive version stored on home server for course. If local copy is
8503: stale, requests a new version from the home server and stores it.
8504: If the original has been removed from the home server, then local copy
8505: is unlinked.
8506: (ii) If local copy does not exist -
8507: requests the file from the home server and stores it.
8508:
8509: If $caller is 'uploadrep':
8510: This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
8511: for request for files originally uploaded via DOCS.
8512: - returns 'ok' if fresh local copy now available, -1 otherwise.
8513:
8514: Otherwise:
8515: This indicates a call from the content generation phase of the request.
8516: - returns the entire contents of the file or -1.
8517:
8518: (b) files in /res
8519: - returns the entire contents of a file or -1;
8520: it properly subscribes to and replicates the file if neccessary.
1.191 harris41 8521:
1.712 albertel 8522:
8523: =item *
8524:
8525: stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
8526: reference
8527:
8528: returns either a stat() list of data about the file or an empty list
8529: if the file doesn't exist or couldn't find out about it (connection
8530: problems or user unknown)
8531:
1.191 harris41 8532: =item *
8533:
1.243 albertel 8534: filelocation($dir,$file) : returns file system location of a file
8535: based on URI; meant to be "fairly clean" absolute reference, $dir is a
8536: directory that relative $file lookups are to looked in ($dir of /a/dir
8537: and a file of ../bob will become /a/bob)
1.191 harris41 8538:
8539: =item *
8540:
8541: hreflocation($dir,$file) : returns file system location or a URL; same as
8542: filelocation except for hrefs
8543:
8544: =item *
8545:
8546: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
8547:
1.243 albertel 8548: =back
8549:
1.608 albertel 8550: =head2 Usererfile file routines (/uploaded*)
8551:
8552: =over 4
8553:
8554: =item *
8555:
8556: userfileupload(): main rotine for putting a file in a user or course's
8557: filespace, arguments are,
8558:
1.620 albertel 8559: formname - required - this is the name of the element in $env where the
1.608 albertel 8560: filename, and the contents of the file to create/modifed exist
1.620 albertel 8561: the filename is in $env{'form.'.$formname.'.filename'} and the
8562: contents of the file is located in $env{'form.'.$formname}
1.608 albertel 8563: coursedoc - if true, store the file in the course of the active role
8564: of the current user
8565: subdir - required - subdirectory to put the file in under ../userfiles/
8566: if undefined, it will be placed in "unknown"
8567:
8568: (This routine calls clean_filename() to remove any dangerous
8569: characters from the filename, and then calls finuserfileupload() to
8570: complete the transaction)
8571:
8572: returns either the url of the uploaded file (/uploaded/....) if successful
8573: and /adm/notfound.html if unsuccessful
8574:
8575: =item *
8576:
8577: clean_filename(): routine for cleaing a filename up for storage in
8578: userfile space, argument is:
8579:
8580: filename - proposed filename
8581:
8582: returns: the new clean filename
8583:
8584: =item *
8585:
8586: finishuserfileupload(): routine that creaes and sends the file to
8587: userspace, probably shouldn't be called directly
8588:
8589: docuname: username or courseid of destination for the file
8590: docudom: domain of user/course of destination for the file
8591: formname: same as for userfileupload()
8592: fname: filename (inculding subdirectories) for the file
8593:
8594: returns either the url of the uploaded file (/uploaded/....) if successful
8595: and /adm/notfound.html if unsuccessful
8596:
8597: =item *
8598:
8599: renameuserfile(): renames an existing userfile to a new name
8600:
8601: Args:
8602: docuname: username or courseid of destination for the file
8603: docudom: domain of user/course of destination for the file
8604: old: current file name (including any subdirs under userfiles)
8605: new: desired file name (including any subdirs under userfiles)
8606:
8607: =item *
8608:
8609: mkdiruserfile(): creates a directory is a userfiles dir
8610:
8611: Args:
8612: docuname: username or courseid of destination for the file
8613: docudom: domain of user/course of destination for the file
8614: dir: dir to create (including any subdirs under userfiles)
8615:
8616: =item *
8617:
8618: removeuserfile(): removes a file that exists in userfiles
8619:
8620: Args:
8621: docuname: username or courseid of destination for the file
8622: docudom: domain of user/course of destination for the file
8623: fname: filname to delete (including any subdirs under userfiles)
8624:
8625: =item *
8626:
8627: removeuploadedurl(): convience function for removeuserfile()
8628:
8629: Args:
8630: url: a full /uploaded/... url to delete
8631:
1.747 albertel 8632: =item *
8633:
8634: get_portfile_permissions():
8635: Args:
8636: domain: domain of user or course contain the portfolio files
8637: user: name of user or num of course contain the portfolio files
8638: Returns:
8639: hashref of a dump of the proper file_permissions.db
8640:
8641:
8642: =item *
8643:
8644: get_access_controls():
8645:
8646: Args:
8647: current_permissions: the hash ref returned from get_portfile_permissions()
8648: group: (optional) the group you want the files associated with
8649: file: (optional) the file you want access info on
8650:
8651: Returns:
1.749 raeburn 8652: a hash (keys are file names) of hashes containing
8653: keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
8654: values are XML containing access control settings (see below)
1.747 albertel 8655:
8656: Internal notes:
8657:
1.749 raeburn 8658: access controls are stored in file_permissions.db as key=value pairs.
8659: key -> path to file/file_name\0uniqueID:scope_end_start
8660: where scope -> public,guest,course,group,domains or users.
8661: end -> UNIX time for end of access (0 -> no end date)
8662: start -> UNIX time for start of access
8663:
8664: value -> XML description of access control
8665: <scope type=""> (type =1 of: public,guest,course,group,domains,users">
8666: <start></start>
8667: <end></end>
8668:
8669: <password></password> for scope type = guest
8670:
8671: <domain></domain> for scope type = course or group
8672: <number></number>
8673: <roles id="">
8674: <role></role>
8675: <access></access>
8676: <section></section>
8677: <group></group>
8678: </roles>
8679:
8680: <dom></dom> for scope type = domains
8681:
8682: <users> for scope type = users
8683: <user>
8684: <uname></uname>
8685: <udom></udom>
8686: </user>
8687: </users>
8688: </scope>
8689:
8690: Access data is also aggregated for each file in an additional key=value pair:
8691: key -> path to file/file_name\0accesscontrol
8692: value -> reference to hash
8693: hash contains key = value pairs
8694: where key = uniqueID:scope_end_start
8695: value = UNIX time record was last updated
8696:
8697: Used to improve speed of look-ups of access controls for each file.
8698:
8699: Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
8700:
8701: modify_access_controls():
8702:
8703: Modifies access controls for a portfolio file
8704: Args
8705: 1. file name
8706: 2. reference to hash of required changes,
8707: 3. domain
8708: 4. username
8709: where domain,username are the domain of the portfolio owner
8710: (either a user or a course)
8711:
8712: Returns:
8713: 1. result of additions or updates ('ok' or 'error', with error message).
8714: 2. result of deletions ('ok' or 'error', with error message).
8715: 3. reference to hash of any new or updated access controls.
8716: 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
8717: key = integer (inbound ID)
8718: value = uniqueID
1.747 albertel 8719:
1.608 albertel 8720: =back
8721:
1.243 albertel 8722: =head2 HTTP Helper Routines
8723:
8724: =over 4
8725:
1.191 harris41 8726: =item *
8727:
8728: escape() : unpack non-word characters into CGI-compatible hex codes
8729:
8730: =item *
8731:
8732: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
8733:
1.243 albertel 8734: =back
8735:
8736: =head1 PRIVATE SUBROUTINES
8737:
8738: =head2 Underlying communication routines (Shouldn't call)
8739:
8740: =over 4
8741:
8742: =item *
8743:
8744: subreply() : tries to pass a message to lonc, returns con_lost if incapable
8745:
8746: =item *
8747:
8748: reply() : uses subreply to send a message to remote machine, logs all failures
8749:
8750: =item *
8751:
8752: critical() : passes a critical message to another server; if cannot
8753: get through then place message in connection buffer directory and
8754: returns con_delayed, if incapable of saving message, returns
8755: con_failed
8756:
8757: =item *
8758:
8759: reconlonc() : tries to reconnect lonc client processes.
8760:
8761: =back
8762:
8763: =head2 Resource Access Logging
8764:
8765: =over 4
8766:
8767: =item *
8768:
8769: flushcourselogs() : flush (save) buffer logs and access logs
8770:
8771: =item *
8772:
8773: courselog($what) : save message for course in hash
8774:
8775: =item *
8776:
8777: courseacclog($what) : save message for course using &courselog(). Perform
8778: special processing for specific resource types (problems, exams, quizzes, etc).
8779:
1.191 harris41 8780: =item *
8781:
8782: goodbye() : flush course logs and log shutting down; it is called in srm.conf
8783: as a PerlChildExitHandler
1.243 albertel 8784:
8785: =back
8786:
8787: =head2 Other
8788:
8789: =over 4
8790:
8791: =item *
8792:
8793: symblist($mapname,%newhash) : update symbolic storage links
1.191 harris41 8794:
8795: =back
8796:
8797: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl