File:  [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.1507: download - view: text, annotated - select for diffs
Wed Apr 5 18:09:52 2023 UTC (15 months, 3 weeks ago) by raeburn
Branches: MAIN
CVS tags: HEAD
- Bug 2832
  Display Edit button in Functions menu for published resource in a course,
  where role is instructor.

    1: # The LearningOnline Network
    2: # TCP networking package
    3: #
    4: # $Id: lonnet.pm,v 1.1507 2023/04/05 18:09:52 raeburn Exp $
    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: #
   28: ###
   29: 
   30: =pod
   31: 
   32: =head1 NAME
   33: 
   34: Apache::lonnet.pm
   35: 
   36: =head1 SYNOPSIS
   37: 
   38: This file is an interface to the lonc processes of
   39: the LON-CAPA network as well as set of elaborated functions for handling information
   40: necessary for navigating through a given cluster of LON-CAPA machines within a
   41: domain. There are over 40 specialized functions in this module which handle the
   42: reading and transmission of metadata, user information (ids, names, environments, roles,
   43: logs), file information (storage, reading, directories, extensions, replication, embedded
   44: styles and descriptors), educational resources (course descriptions, section names and
   45: numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
   46: and from more descriptive phrases or explanations.
   47: 
   48: This is part of the LearningOnline Network with CAPA project
   49: described at http://www.lon-capa.org.
   50: 
   51: =head1 Package Variables
   52: 
   53: These are largely undocumented, so if you decipher one please note it here.
   54: 
   55: =over 4
   56: 
   57: =item $processmarker
   58: 
   59: Contains the time this process was started and this servers host id.
   60: 
   61: =item $dumpcount
   62: 
   63: Counts the number of times a message log flush has been attempted (regardless
   64: of success) by this process.  Used as part of the filename when messages are
   65: delayed.
   66: 
   67: =back
   68: 
   69: =cut
   70: 
   71: package Apache::lonnet;
   72: 
   73: use strict;
   74: use HTTP::Date;
   75: use Image::Magick;
   76: use CGI::Cookie;
   77: 
   78: use Encode;
   79: 
   80: use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
   81:             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
   82:             %managerstab $passwdmin);
   83: 
   84: my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
   85:     %userrolehash, $processmarker, $dumpcount, %coursedombuf,
   86:     %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
   87:     %courseownerbuf, %coursetypebuf,$locknum);
   88: 
   89: use IO::Socket;
   90: use GDBM_File;
   91: use HTML::LCParser;
   92: use Fcntl qw(:flock);
   93: use Storable qw(thaw nfreeze);
   94: use Time::HiRes qw( sleep gettimeofday tv_interval );
   95: use Cache::Memcached;
   96: use Digest::MD5;
   97: use Math::Random;
   98: use File::MMagic;
   99: use Net::CIDR;
  100: use Sys::Hostname::FQDN();
  101: use LONCAPA qw(:DEFAULT :match);
  102: use LONCAPA::Configuration;
  103: use LONCAPA::lonmetadata;
  104: use LONCAPA::Lond;
  105: use LONCAPA::LWPReq;
  106: use LONCAPA::transliterate;
  107: 
  108: use File::Copy;
  109: 
  110: my $readit;
  111: my $max_connection_retries = 20;     # Or some such value.
  112: 
  113: require Exporter;
  114: 
  115: our @ISA = qw (Exporter);
  116: our @EXPORT = qw(%env);
  117: 
  118: 
  119: # ------------------------------------ Logging (parameters, docs, slots, roles)
  120: {
  121:     my $logid;
  122:     sub write_log {
  123: 	my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
  124:         if ($context eq 'course') {
  125:             if (($cnum eq '') || ($cdom eq '')) {
  126:                 $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
  127:                 $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
  128:             }
  129:         }
  130: 	$logid ++;
  131:         my $now = time();
  132: 	my $id=$now.'00000'.$$.'00000'.$logid;
  133:         my $ip = &get_requestor_ip();
  134:         my $logentry = { 
  135:                           $id => {
  136:                                    'exe_uname' => $env{'user.name'},
  137:                                    'exe_udom'  => $env{'user.domain'},
  138:                                    'exe_time'  => $now,
  139:                                    'exe_ip'    => $ip,
  140:                                    'delflag'   => $delflag,
  141:                                    'logentry'  => $storehash,
  142:                                    'uname'     => $uname,
  143:                                    'udom'      => $udom,
  144:                                   }
  145:                        };
  146: 	return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
  147:     }
  148: }
  149: 
  150: sub logtouch {
  151:     my $execdir=$perlvar{'lonDaemons'};
  152:     unless (-e "$execdir/logs/lonnet.log") {	
  153: 	open(my $fh,">>","$execdir/logs/lonnet.log");
  154: 	close $fh;
  155:     }
  156:     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
  157:     chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
  158: }
  159: 
  160: sub logthis {
  161:     my $message=shift;
  162:     my $execdir=$perlvar{'lonDaemons'};
  163:     my $now=time;
  164:     my $local=localtime($now);
  165:     if (open(my $fh,">>","$execdir/logs/lonnet.log")) {
  166: 	my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
  167: 	print $fh $logstring;
  168: 	close($fh);
  169:     }
  170:     return 1;
  171: }
  172: 
  173: sub logperm {
  174:     my $message=shift;
  175:     my $execdir=$perlvar{'lonDaemons'};
  176:     my $now=time;
  177:     my $local=localtime($now);
  178:     if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) {
  179: 	print $fh "$now:$message:$local\n";
  180: 	close($fh);
  181:     }
  182:     return 1;
  183: }
  184: 
  185: sub create_connection {
  186:     my ($hostname,$lonid) = @_;
  187:     my $client=IO::Socket::UNIX->new(Peer    => $perlvar{'lonSockCreate'},
  188: 				     Type    => SOCK_STREAM,
  189: 				     Timeout => 10);
  190:     return 0 if (!$client);
  191:     print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
  192:     my $result = <$client>;
  193:     chomp($result);
  194:     return 1 if ($result eq 'done');
  195:     return 0;
  196: }
  197: 
  198: sub get_server_timezone {
  199:     my ($cnum,$cdom) = @_;
  200:     my $home=&homeserver($cnum,$cdom);
  201:     if ($home ne 'no_host') {
  202:         my $cachetime = 24*3600;
  203:         my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
  204:         if (defined($cached)) {
  205:             return $timezone;
  206:         } else {
  207:             my $timezone = &reply('servertimezone',$home);
  208:             return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
  209:         }
  210:     }
  211: }
  212: 
  213: sub get_server_distarch {
  214:     my ($lonhost,$ignore_cache) = @_;
  215:     if (defined($lonhost)) {
  216:         if (!defined(&hostname($lonhost))) {
  217:             return;
  218:         }
  219:         my $cachetime = 12*3600;
  220:         if (!$ignore_cache) {
  221:             my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost);
  222:             if (defined($cached)) {
  223:                 return $distarch;
  224:             }
  225:         }
  226:         my $rep = &reply('serverdistarch',$lonhost);
  227:         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
  228:                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
  229:                 $rep eq '') {
  230:             return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
  231:         }
  232:     }
  233:     return;
  234: }
  235: 
  236: sub get_servercerts_info {
  237:     my ($lonhost,$hostname,$context) = @_;
  238:     return if ($lonhost eq '');
  239:     if ($hostname eq '') {
  240:         $hostname = &hostname($lonhost);
  241:     }
  242:     return if ($hostname eq '');
  243:     my ($rep,$uselocal);
  244:     if ($context eq 'install') {
  245:         $uselocal = 1;
  246:     } elsif (grep { $_ eq $lonhost } &current_machine_ids()) {
  247:         $uselocal = 1;
  248:     }
  249:     if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
  250:         my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
  251:         if ($distro eq '') {
  252:             $uselocal = 0;
  253:         } elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) {
  254:             if ($1 < 6) {
  255:                 $uselocal = 0;
  256:             }
  257:         }  elsif ($distro =~ /^(?:sles)(\d+)$/) {
  258:             if ($1 < 12) {
  259:                 $uselocal = 0;
  260:             }
  261:         }
  262:     }
  263:     if ($uselocal) {
  264:         $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname);
  265:     } else {
  266:         $rep=&reply('servercerts',$lonhost);
  267:     }
  268:     my ($result,%returnhash);
  269:     if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
  270:         ($rep eq 'unknown_cmd')) {
  271:         $result = $rep;
  272:     } else {
  273:         $result = 'ok';
  274:         my @pairs=split(/\&/,$rep);
  275:         foreach my $item (@pairs) {
  276:             my ($key,$value)=split(/=/,$item,2);
  277:             my $what = &unescape($key);
  278:             $returnhash{$what}=&thaw_unescape($value);
  279:         }
  280:     }
  281:     return ($result,\%returnhash);
  282: }
  283: 
  284: sub get_server_loncaparev {
  285:     my ($dom,$lonhost,$ignore_cache,$caller) = @_;
  286:     if (defined($lonhost)) {
  287:         if (!defined(&hostname($lonhost))) {
  288:             undef($lonhost);
  289:         }
  290:     }
  291:     if (!defined($lonhost)) {
  292:         if (defined(&domain($dom,'primary'))) {
  293:             $lonhost=&domain($dom,'primary');
  294:             if ($lonhost eq 'no_host') {
  295:                 undef($lonhost);
  296:             }
  297:         }
  298:     }
  299:     if (defined($lonhost)) {
  300:         my $cachetime = 12*3600;
  301:         if (!$ignore_cache) {
  302:             my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
  303:             if (defined($cached)) {
  304:                 return $loncaparev;
  305:             }
  306:         }
  307:         my ($answer,$loncaparev);
  308:         my @ids=&current_machine_ids();
  309:         if (grep(/^\Q$lonhost\E$/,@ids)) {
  310:             $answer = $perlvar{'lonVersion'};
  311:             if ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {
  312:                 $loncaparev = $1;
  313:             }
  314:         } else {
  315:             $answer = &reply('serverloncaparev',$lonhost);
  316:             if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
  317:                 if ($caller eq 'loncron') {
  318:                     my $hostname = &hostname($lonhost);
  319:                     my $protocol = $protocol{$lonhost};
  320:                     $protocol = 'http' if ($protocol ne 'https');
  321:                     my $url = $protocol.'://'.$hostname.'/adm/about.html';
  322:                     my $request=new HTTP::Request('GET',$url);
  323:                     my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
  324:                     unless ($response->is_error()) {
  325:                         my $content = $response->content;
  326:                         if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
  327:                             $loncaparev = $1;
  328:                         }
  329:                     }
  330:                 } else {
  331:                     $loncaparev = $loncaparevs{$lonhost};
  332:                 }
  333:             } elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {
  334:                 $loncaparev = $1;
  335:             }
  336:         }
  337:         return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
  338:     }
  339: }
  340: 
  341: sub get_server_homeID {
  342:     my ($hostname,$ignore_cache,$caller) = @_;
  343:     unless ($ignore_cache) {
  344:         my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname);
  345:         if (defined($cached)) {
  346:             return $serverhomeID;
  347:         }
  348:     }
  349:     my $cachetime = 12*3600;
  350:     my $serverhomeID;
  351:     if ($caller eq 'loncron') { 
  352:         my @machine_ids = &machine_ids($hostname);
  353:         foreach my $id (@machine_ids) {
  354:             my $response = &reply('serverhomeID',$id);
  355:             unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) {
  356:                 $serverhomeID = $response;
  357:                 last;
  358:             }
  359:         }
  360:         if ($serverhomeID eq '') {
  361:             $serverhomeID = $machine_ids[-1];
  362:         }
  363:     } else {
  364:         $serverhomeID = $serverhomeIDs{$hostname};
  365:     }
  366:     return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);
  367: }
  368: 
  369: sub get_remote_globals {
  370:     my ($lonhost,$whathash,$ignore_cache) = @_;
  371:     my ($result,%returnhash,%whatneeded);
  372:     if (ref($whathash) eq 'HASH') {
  373:         foreach my $what (sort(keys(%{$whathash}))) {
  374:             my $hashid = $lonhost.'-'.$what;
  375:             my ($response,$cached);
  376:             unless ($ignore_cache) {
  377:                 ($response,$cached)=&is_cached_new('lonnetglobal',$hashid);
  378:             }
  379:             if (defined($cached)) {
  380:                 $returnhash{$what} = $response;
  381:             } else {
  382:                 $whatneeded{$what} = 1;
  383:             }
  384:         }
  385:         if (keys(%whatneeded) == 0) {
  386:             $result = 'ok';
  387:         } else {
  388:             my $requested = &freeze_escape(\%whatneeded);
  389:             my $rep=&reply('readlonnetglobal:'.$requested,$lonhost);
  390:             if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
  391:                 ($rep eq 'unknown_cmd')) {
  392:                 $result = $rep;
  393:             } else {
  394:                 $result = 'ok';
  395:                 my @pairs=split(/\&/,$rep);
  396:                 foreach my $item (@pairs) {
  397:                     my ($key,$value)=split(/=/,$item,2);
  398:                     my $what = &unescape($key);
  399:                     my $hashid = $lonhost.'-'.$what;
  400:                     $returnhash{$what}=&thaw_unescape($value);
  401:                     &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
  402:                 }
  403:             }
  404:         }
  405:     }
  406:     return ($result,\%returnhash);
  407: }
  408: 
  409: sub remote_devalidate_cache {
  410:     my ($lonhost,$cachekeys) = @_;
  411:     my $items;
  412:     return unless (ref($cachekeys) eq 'ARRAY');
  413:     my $cachestr = join('&',@{$cachekeys});
  414:     my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
  415:     return $response;
  416: }
  417: 
  418: # -------------------------------------------------- Non-critical communication
  419: sub subreply {
  420:     my ($cmd,$server)=@_;
  421:     my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
  422:     #
  423:     #  With loncnew process trimming, there's a timing hole between lonc server
  424:     #  process exit and the master server picking up the listen on the AF_UNIX
  425:     #  socket.  In that time interval, a lock file will exist:
  426: 
  427:     my $lockfile=$peerfile.".lock";
  428:     while (-e $lockfile) {	# Need to wait for the lockfile to disappear.
  429: 	sleep(0.1);
  430:     }
  431:     # At this point, either a loncnew parent is listening or an old lonc
  432:     # or loncnew child is listening so we can connect or everything's dead.
  433:     #
  434:     #   We'll give the connection a few tries before abandoning it.  If
  435:     #   connection is not possible, we'll con_lost back to the client.
  436:     #   
  437:     my $client;
  438:     for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
  439: 	$client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  440: 				      Type    => SOCK_STREAM,
  441: 				      Timeout => 10);
  442: 	if ($client) {
  443: 	    last;		# Connected!
  444: 	} else {
  445: 	    &create_connection(&hostname($server),$server);
  446: 	}
  447:         sleep(0.1);	# Try again later if failed connection.
  448:     }
  449:     my $answer;
  450:     if ($client) {
  451: 	print $client "sethost:$server:$cmd\n";
  452: 	$answer=<$client>;
  453: 	if (!$answer) { $answer="con_lost"; }
  454: 	chomp($answer);
  455:     } else {
  456: 	$answer = 'con_lost';	# Failed connection.
  457:     }
  458:     return $answer;
  459: }
  460: 
  461: sub reply {
  462:     my ($cmd,$server)=@_;
  463:     unless (defined(&hostname($server))) { return 'no_such_host'; }
  464:     my $answer=subreply($cmd,$server);
  465:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
  466:         my $logged = $cmd;
  467:         if ($cmd =~ /^encrypt:([^:]+):/) {
  468:             my $subcmd = $1;
  469:             if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||
  470:                 ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
  471:                 ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades') ||
  472:                 ($subcmd eq 'put')) {
  473:                 (undef,undef,my @rest) = split(/:/,$cmd);
  474:                 if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
  475:                     splice(@rest,2,1,'Hidden');
  476:                 } elsif ($subcmd eq 'passwd') {
  477:                     splice(@rest,2,2,('Hidden','Hidden'));
  478:                 } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
  479:                          ($subcmd eq 'autoexportgrades') || ($subcmd eq 'put')) {
  480:                     splice(@rest,3,1,'Hidden');
  481:                 }
  482:                 $logged = join(':',('encrypt:'.$subcmd,@rest));
  483:             }
  484:         }
  485:         &logthis("<font color=\"blue\">WARNING:".
  486:                  " $logged to $server returned $answer</font>");
  487:     }
  488:     return $answer;
  489: }
  490: 
  491: # ----------------------------------------------------------- Send USR1 to lonc
  492: 
  493: sub reconlonc {
  494:     my ($lonid) = @_;
  495:     if ($lonid) {
  496:         my $hostname = &hostname($lonid);
  497: 	my $peerfile="$perlvar{'lonSockDir'}/$hostname";
  498: 	if ($hostname && -e $peerfile) {
  499: 	    &logthis("Trying to reconnect lonc for $lonid ($hostname)");
  500: 	    my $client=IO::Socket::UNIX->new(Peer    => $peerfile,
  501: 					     Type    => SOCK_STREAM,
  502: 					     Timeout => 10);
  503: 	    if ($client) {
  504: 		print $client ("reset_retries\n");
  505: 		my $answer=<$client>;
  506: 		#reset just this one.
  507: 	    }
  508: 	}
  509: 	return;
  510:     }
  511: 
  512:     &logthis("Trying to reconnect lonc");
  513:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
  514:     if (open(my $fh,"<",$loncfile)) {
  515: 	my $loncpid=<$fh>;
  516:         chomp($loncpid);
  517:         if (kill 0 => $loncpid) {
  518: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
  519:             kill USR1 => $loncpid;
  520:             sleep 1;
  521:         } else {
  522: 	    &logthis(
  523:                "<font color=\"blue\">WARNING:".
  524:                " lonc at pid $loncpid not responding, giving up</font>");
  525:         }
  526:     } else {
  527: 	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
  528:     }
  529: }
  530: 
  531: # ------------------------------------------------------ Critical communication
  532: 
  533: sub critical {
  534:     my ($cmd,$server)=@_;
  535:     unless (&hostname($server)) {
  536:         &logthis("<font color=\"blue\">WARNING:".
  537:                " Critical message to unknown server ($server)</font>");
  538:         return 'no_such_host';
  539:     }
  540:     my $answer=reply($cmd,$server);
  541:     if ($answer eq 'con_lost') {
  542: 	&reconlonc($server);
  543: 	my $answer=reply($cmd,$server);
  544:         if ($answer eq 'con_lost') {
  545:             my $now=time;
  546:             my $middlename=$cmd;
  547:             $middlename=substr($middlename,0,16);
  548:             $middlename=~s/\W//g;
  549:             my $dfilename=
  550:       "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
  551:             $dumpcount++;
  552:             {
  553: 		my $dfh;
  554: 		if (open($dfh,">",$dfilename)) {
  555: 		    print $dfh "$cmd\n"; 
  556: 		    close($dfh);
  557: 		}
  558:             }
  559:             sleep 1;
  560:             my $wcmd='';
  561:             {
  562: 		my $dfh;
  563: 		if (open($dfh,"<",$dfilename)) {
  564: 		    $wcmd=<$dfh>; 
  565: 		    close($dfh);
  566: 		}
  567:             }
  568:             chomp($wcmd);
  569:             if ($wcmd eq $cmd) {
  570: 		&logthis("<font color=\"blue\">WARNING: ".
  571:                          "Connection buffer $dfilename: $cmd</font>");
  572:                 &logperm("D:$server:$cmd");
  573: 	        return 'con_delayed';
  574:             } else {
  575:                 &logthis("<font color=\"red\">CRITICAL:"
  576:                         ." Critical connection failed: $server $cmd</font>");
  577:                 &logperm("F:$server:$cmd");
  578:                 return 'con_failed';
  579:             }
  580:         }
  581:     }
  582:     return $answer;
  583: }
  584: 
  585: # ------------------------------------------- check if return value is an error
  586: 
  587: sub error {
  588:     my ($result) = @_;
  589:     if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
  590: 	if ($2 == 2) { return undef; }
  591: 	return $1;
  592:     }
  593:     return undef;
  594: }
  595: 
  596: sub convert_and_load_session_env {
  597:     my ($lonidsdir,$handle)=@_;
  598:     my @profile;
  599:     {
  600: 	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
  601: 	if (!$opened) {
  602: 	    return 0;
  603: 	}
  604: 	flock($idf,LOCK_SH);
  605: 	@profile=<$idf>;
  606: 	close($idf);
  607:     }
  608:     my %temp_env;
  609:     foreach my $line (@profile) {
  610: 	if ($line !~ m/=/) {
  611: 	    return 0;
  612: 	}
  613: 	chomp($line);
  614: 	my ($envname,$envvalue)=split(/=/,$line,2);
  615: 	$temp_env{&unescape($envname)} = &unescape($envvalue);
  616:     }
  617:     unlink("$lonidsdir/$handle.id");
  618:     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
  619: 	    0640)) {
  620: 	%disk_env = %temp_env;
  621: 	@env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
  622: 	untie(%disk_env);
  623:     }
  624:     return 1;
  625: }
  626: 
  627: # ------------------------------------------- Transfer profile into environment
  628: my $env_loaded;
  629: sub transfer_profile_to_env {
  630:     my ($lonidsdir,$handle,$force_transfer) = @_;
  631:     if (!$force_transfer && $env_loaded) { return; } 
  632: 
  633:     if (!defined($lonidsdir)) {
  634: 	$lonidsdir = $perlvar{'lonIDsDir'};
  635:     }
  636:     if (!defined($handle)) {
  637:         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
  638:     }
  639: 
  640:     my $convert;
  641:     {
  642:     	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
  643: 	if (!$opened) {
  644: 	    return;
  645: 	}
  646: 	flock($idf,LOCK_SH);
  647: 	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  648: 		&GDBM_READER(),0640)) {
  649: 	    @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
  650: 	    untie(%disk_env);
  651: 	} else {
  652: 	    $convert = 1;
  653: 	}
  654:     }
  655:     if ($convert) {
  656: 	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
  657: 	    &logthis("Failed to load session, or convert session.");
  658: 	}
  659:     }
  660: 
  661:     my %remove;
  662:     while ( my $envname = each(%env) ) {
  663:         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
  664:             if ($time < time-300) {
  665:                 $remove{$key}++;
  666:             }
  667:         }
  668:     }
  669: 
  670:     $env{'user.environment'} = "$lonidsdir/$handle.id";
  671:     $env_loaded=1;
  672:     foreach my $expired_key (keys(%remove)) {
  673:         &delenv($expired_key);
  674:     }
  675: }
  676: 
  677: # ---------------------------------------------------- Check for valid session 
  678: sub check_for_valid_session {
  679:     my ($r,$name,$userhashref,$domref) = @_;
  680:     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
  681:     my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
  682:     if ($name eq 'lonDAV') {
  683:         $lonidsdir=$r->dir_config('lonDAVsessDir');
  684:     } else {
  685:         $lonidsdir=$r->dir_config('lonIDsDir');
  686:         if ($name eq '') {
  687:             $name = 'lonID';
  688:         }
  689:     }
  690:     if ($name eq 'lonID') {
  691:         $secure = 'lonSID';
  692:         $linkname = 'lonLinkID';
  693:         $pubname = 'lonPubID';
  694:         if (exists($cookies{$secure})) {
  695:             $lonid=$cookies{$secure};
  696:         } elsif (exists($cookies{$name})) {
  697:             $lonid=$cookies{$name};
  698:         } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
  699:             $lonid=$cookies{$linkname};
  700:         } elsif (exists($cookies{$pubname})) {
  701:             $lonid=$cookies{$pubname};
  702:         }
  703:     } else {
  704:         $lonid=$cookies{$name};
  705:     }
  706:     return undef if (!$lonid);
  707: 
  708:     my $handle=&LONCAPA::clean_handle($lonid->value);
  709:     if (-l "$lonidsdir/$handle.id") {
  710:         my $link = readlink("$lonidsdir/$handle.id");
  711:         if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
  712:             $handle = $1;
  713:         }
  714:     }
  715:     if (!-e "$lonidsdir/$handle.id") {
  716:         if ((ref($domref)) && ($name eq 'lonID') && 
  717:             ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
  718:             my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
  719:             if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
  720:                 $$domref = $possudom;
  721:             }
  722:         }
  723:         return undef;
  724:     }
  725: 
  726:     my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
  727:     return undef if (!$opened);
  728: 
  729:     flock($idf,LOCK_SH);
  730:     my %disk_env;
  731:     if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  732: 	    &GDBM_READER(),0640)) {
  733: 	return undef;	
  734:     }
  735: 
  736:     if (!defined($disk_env{'user.name'})
  737: 	|| !defined($disk_env{'user.domain'})) {
  738:         untie(%disk_env);
  739: 	return undef;
  740:     }
  741: 
  742:     if (ref($userhashref) eq 'HASH') {
  743:         $userhashref->{'name'} = $disk_env{'user.name'};
  744:         $userhashref->{'domain'} = $disk_env{'user.domain'};
  745:         if ($disk_env{'request.role'}) {
  746:             $userhashref->{'role'} = $disk_env{'request.role'};
  747:         }
  748:         $userhashref->{'lti'} = $disk_env{'request.lti.login'};
  749:         if ($userhashref->{'lti'}) {
  750:             $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
  751:             $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
  752:         }
  753:     }
  754:     untie(%disk_env);
  755: 
  756:     return $handle;
  757: }
  758: 
  759: sub timed_flock {
  760:     my ($file,$lock_type) = @_;
  761:     my $failed=0;
  762:     eval {
  763: 	local $SIG{__DIE__}='DEFAULT';
  764: 	local $SIG{ALRM}=sub {
  765: 	    $failed=1;
  766: 	    die("failed lock");
  767: 	};
  768: 	alarm(13);
  769: 	flock($file,$lock_type);
  770: 	alarm(0);
  771:     };
  772:     if ($failed) {
  773: 	return undef;
  774:     } else {
  775: 	return 1;
  776:     }
  777: }
  778: 
  779: sub get_sessionfile_vars {
  780:     my ($handle,$lonidsdir,$storearr) = @_;
  781:     my %returnhash;
  782:     unless (ref($storearr) eq 'ARRAY') {
  783:         return %returnhash;
  784:     }
  785:     if (-l "$lonidsdir/$handle.id") {
  786:         my $link = readlink("$lonidsdir/$handle.id");
  787:         if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
  788:             $handle = $1;
  789:         }
  790:     }
  791:     if ((-e "$lonidsdir/$handle.id") &&
  792:         ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
  793:         my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
  794:         if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
  795:             if (open(my $idf,'+<',"$lonidsdir/$handle.id")) {
  796:                 flock($idf,LOCK_SH);
  797:                 if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  798:                         &GDBM_READER(),0640)) {
  799:                     foreach my $item (@{$storearr}) {
  800:                         $returnhash{$item} = $disk_env{$item};
  801:                     }
  802:                     untie(%disk_env);
  803:                 }
  804:             }
  805:         }
  806:     }
  807:     return %returnhash;
  808: }
  809: 
  810: # ---------------------------------------------------------- Append Environment
  811: 
  812: sub appenv {
  813:     my ($newenv,$roles) = @_;
  814:     if (ref($newenv) eq 'HASH') {
  815:         foreach my $key (keys(%{$newenv})) {
  816:             my $refused = 0;
  817: 	    if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
  818:                 $refused = 1;
  819:                 if (ref($roles) eq 'ARRAY') {
  820:                     my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});
  821:                     if (grep(/^\Q$role\E$/,@{$roles})) {
  822:                         $refused = 0;
  823:                     }
  824:                 }
  825:             }
  826:             if ($refused) {
  827:                 &logthis("<font color=\"blue\">WARNING: ".
  828:                          "Attempt to modify environment ".$key." to ".$newenv->{$key}
  829:                          .'</font>');
  830: 	        delete($newenv->{$key});
  831:             } else {
  832:                 $env{$key}=$newenv->{$key};
  833:             }
  834:         }
  835:         my $lonids = $perlvar{'lonIDsDir'};
  836:         if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
  837:             my $opened = open(my $env_file,'+<',$env{'user.environment'});
  838:             if ($opened
  839: 	        && &timed_flock($env_file,LOCK_EX)
  840: 	        &&
  841: 	        tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  842: 	            (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  843: 	        while (my ($key,$value) = each(%{$newenv})) {
  844: 	            $disk_env{$key} = $value;
  845: 	        }
  846: 	        untie(%disk_env);
  847:             }
  848:         }
  849:     }
  850:     return 'ok';
  851: }
  852: # ----------------------------------------------------- Delete from Environment
  853: 
  854: sub delenv {
  855:     my ($delthis,$regexp,$roles) = @_;
  856:     if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) {
  857:         my $refused = 1;
  858:         if (ref($roles) eq 'ARRAY') {
  859:             my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./);
  860:             if (grep(/^\Q$role\E$/,@{$roles})) {
  861:                 $refused = 0;
  862:             }
  863:         }
  864:         if ($refused) {
  865:             &logthis("<font color=\"blue\">WARNING: ".
  866:                      "Attempt to delete from environment ".$delthis);
  867:             return 'error';
  868:         }
  869:     }
  870:     my $opened = open(my $env_file,'+<',$env{'user.environment'});
  871:     if ($opened
  872: 	&& &timed_flock($env_file,LOCK_EX)
  873: 	&&
  874: 	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  875: 	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  876: 	foreach my $key (keys(%disk_env)) {
  877: 	    if ($regexp) {
  878:                 if ($key=~/^$delthis/) {
  879:                     delete($env{$key});
  880:                     delete($disk_env{$key});
  881:                 } 
  882:             } else {
  883:                 if ($key=~/^\Q$delthis\E/) {
  884: 		    delete($env{$key});
  885: 		    delete($disk_env{$key});
  886: 	        }
  887:             }
  888: 	}
  889: 	untie(%disk_env);
  890:     }
  891:     return 'ok';
  892: }
  893: 
  894: sub get_env_multiple {
  895:     my ($name) = @_;
  896:     my @values;
  897:     if (defined($env{$name})) {
  898:         # exists is it an array
  899:         if (ref($env{$name})) {
  900:             @values=@{ $env{$name} };
  901:         } else {
  902:             $values[0]=$env{$name};
  903:         }
  904:     }
  905:     return(@values);
  906: }
  907: 
  908: # ------------------------------------------------------------------- Locking
  909: 
  910: sub set_lock {
  911:     my ($text)=@_;
  912:     $locknum++;
  913:     my $id=$$.'-'.$locknum;
  914:     &appenv({'session.locks' => $env{'session.locks'}.','.$id,
  915:              'session.lock.'.$id => $text});
  916:     return $id;
  917: }
  918: 
  919: sub get_locks {
  920:     my $num=0;
  921:     my %texts=();
  922:     foreach my $lock (split(/\,/,$env{'session.locks'})) {
  923:        if ($lock=~/\w/) {
  924:           $num++;
  925:           $texts{$lock}=$env{'session.lock.'.$lock};
  926:        }
  927:    }
  928:    return ($num,%texts);
  929: }
  930: 
  931: sub remove_lock {
  932:     my ($id)=@_;
  933:     my $newlocks='';
  934:     foreach my $lock (split(/\,/,$env{'session.locks'})) {
  935:        if (($lock=~/\w/) && ($lock ne $id)) {
  936:           $newlocks.=','.$lock;
  937:        }
  938:     }
  939:     &appenv({'session.locks' => $newlocks});
  940:     &delenv('session.lock.'.$id);
  941: }
  942: 
  943: sub remove_all_locks {
  944:     my $activelocks=$env{'session.locks'};
  945:     foreach my $lock (split(/\,/,$env{'session.locks'})) {
  946:        if ($lock=~/\w/) {
  947:           &remove_lock($lock);
  948:        }
  949:     }
  950: }
  951: 
  952: 
  953: # ------------------------------------------ Find out current server userload
  954: sub userload {
  955:     my $numusers=0;
  956:     {
  957: 	opendir(LONIDS,$perlvar{'lonIDsDir'});
  958: 	my $filename;
  959: 	my $curtime=time;
  960: 	while ($filename=readdir(LONIDS)) {
  961: 	    next if ($filename eq '.' || $filename eq '..');
  962: 	    next if ($filename =~ /publicuser_\d+\.id/);
  963:             next if ($filename =~ /^[a-f0-9]+_linked\.id$/);
  964: 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
  965: 	    if ($curtime-$mtime < 1800) { $numusers++; }
  966: 	}
  967: 	closedir(LONIDS);
  968:     }
  969:     my $userloadpercent=0;
  970:     my $maxuserload=$perlvar{'lonUserLoadLim'};
  971:     if ($maxuserload) {
  972: 	$userloadpercent=100*$numusers/$maxuserload;
  973:     }
  974:     $userloadpercent=sprintf("%.2f",$userloadpercent);
  975:     return $userloadpercent;
  976: }
  977: 
  978: # ------------------------------ Find server with least workload from spare.tab
  979: 
  980: sub spareserver {
  981:     my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
  982:     my $spare_server;
  983:     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
  984:     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
  985:                                                      :  $userloadpercent;
  986:     my ($uint_dom,$remotesessions);
  987:     if (($udom ne '') && (&domain($udom) ne '')) {
  988:         my $uprimary_id = &domain($udom,'primary');
  989:         $uint_dom = &internet_dom($uprimary_id);
  990:         my %udomdefaults = &get_domain_defaults($udom);
  991:         $remotesessions = $udomdefaults{'remotesessions'};
  992:     }
  993:     my $spareshash = &this_host_spares($udom);
  994:     if (ref($spareshash) eq 'HASH') {
  995:         if (ref($spareshash->{'primary'}) eq 'ARRAY') {
  996:             foreach my $try_server (@{ $spareshash->{'primary'} }) {
  997:                 next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
  998:                                              $try_server));
  999: 	        ($spare_server, $lowest_load) =
 1000: 	            &compare_server_load($try_server, $spare_server, $lowest_load);
 1001:             }
 1002:         }
 1003: 
 1004:         my $found_server = ($spare_server ne '' && $lowest_load < 100);
 1005: 
 1006:         if (!$found_server) {
 1007:             if (ref($spareshash->{'default'}) eq 'ARRAY') { 
 1008: 	        foreach my $try_server (@{ $spareshash->{'default'} }) {
 1009:                     next unless (&spare_can_host($udom,$uint_dom,
 1010:                                                  $remotesessions,$try_server));
 1011: 	            ($spare_server, $lowest_load) =
 1012: 		        &compare_server_load($try_server, $spare_server, $lowest_load);
 1013:                 }
 1014: 	    }
 1015:         }
 1016:     }
 1017: 
 1018:     if (!$want_server_name) {
 1019:         if (defined($spare_server)) {
 1020:             my $hostname = &hostname($spare_server);
 1021:             if (defined($hostname)) {
 1022:                 my $protocol = 'http';
 1023:                 if ($protocol{$spare_server} eq 'https') {
 1024:                     $protocol = $protocol{$spare_server};
 1025:                 }
 1026:                 my $alias = &use_proxy_alias($r,$spare_server);
 1027:                 $hostname = $alias if ($alias ne '');
 1028: 	        $spare_server = $protocol.'://'.$hostname;
 1029:             }
 1030:         }
 1031:     }
 1032:     return $spare_server;
 1033: }
 1034: 
 1035: sub compare_server_load {
 1036:     my ($try_server, $spare_server, $lowest_load, $required) = @_;
 1037: 
 1038:     if ($required) {
 1039:         my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);
 1040:         my $remoterev = &get_server_loncaparev(undef,$try_server);
 1041:         my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
 1042:         if (($major eq '' && $minor eq '') ||
 1043:             (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {
 1044:             return ($spare_server,$lowest_load);
 1045:         }
 1046:     }
 1047: 
 1048:     my $loadans     = &reply('load',    $try_server);
 1049:     my $userloadans = &reply('userload',$try_server);
 1050: 
 1051:     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
 1052: 	return ($spare_server, $lowest_load); #didn't get a number from the server
 1053:     }
 1054: 
 1055:     my $load;
 1056:     if ($loadans =~ /\d/) {
 1057: 	if ($userloadans =~ /\d/) {
 1058: 	    #both are numbers, pick the bigger one
 1059: 	    $load = ($loadans > $userloadans) ? $loadans 
 1060: 		                              : $userloadans;
 1061: 	} else {
 1062: 	    $load = $loadans;
 1063: 	}
 1064:     } else {
 1065: 	$load = $userloadans;
 1066:     }
 1067: 
 1068:     if (($load =~ /\d/) && ($load < $lowest_load)) {
 1069: 	$spare_server = $try_server;
 1070: 	$lowest_load  = $load;
 1071:     }
 1072:     return ($spare_server,$lowest_load);
 1073: }
 1074: 
 1075: # --------------------------- ask offload servers if user already has a session
 1076: sub find_existing_session {
 1077:     my ($udom,$uname) = @_;
 1078:     my $spareshash = &this_host_spares($udom);
 1079:     if (ref($spareshash) eq 'HASH') {
 1080:         if (ref($spareshash->{'primary'}) eq 'ARRAY') {
 1081:             foreach my $try_server (@{ $spareshash->{'primary'} }) {
 1082:                 return $try_server if (&has_user_session($try_server, $udom, $uname));
 1083:             }
 1084:         }
 1085:         if (ref($spareshash->{'default'}) eq 'ARRAY') {
 1086:             foreach my $try_server (@{ $spareshash->{'default'} }) {
 1087:                 return $try_server if (&has_user_session($try_server, $udom, $uname));
 1088:             }
 1089:         }
 1090:     }
 1091:     return;
 1092: }
 1093: 
 1094: sub delusersession {
 1095:     my ($lonid,$udom,$uname) = @_;
 1096:     my $uprimary_id = &domain($udom,'primary');
 1097:     my $uintdom = &internet_dom($uprimary_id);
 1098:     my $intdom = &internet_dom($lonid);
 1099:     my $serverhomedom = &host_domain($lonid);
 1100:     if (($uintdom ne '') && ($uintdom eq $intdom)) {
 1101:         return &reply(join(':','delusersession',
 1102:                             map {&escape($_)} ($udom,$uname)),$lonid);
 1103:     }
 1104:     return;
 1105: }
 1106: 
 1107: # check if user's browser sent load balancer cookie and server still has session
 1108: # and is not overloaded.
 1109: sub check_for_balancer_cookie {
 1110:     my ($r,$update_mtime) = @_;
 1111:     my ($otherserver,$cookie);
 1112:     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
 1113:     if (exists($cookies{'balanceID'})) {
 1114:         my $balid = $cookies{'balanceID'};
 1115:         $cookie=&LONCAPA::clean_handle($balid->value);
 1116:         my $balancedir=$r->dir_config('lonBalanceDir');
 1117:         if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) {
 1118:             if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) {
 1119:                 my ($possudom,$possuname) = ($1,$2);
 1120:                 my $has_session = 0;
 1121:                 if ((&domain($possudom) ne '') &&
 1122:                     (&homeserver($possuname,$possudom) ne 'no_host')) {
 1123:                     my $try_server;
 1124:                     my $opened = open(my $idf,'+<',"$balancedir/$cookie.id");
 1125:                     if ($opened) {
 1126:                         flock($idf,LOCK_SH);
 1127:                         while (my $line = <$idf>) {
 1128:                             chomp($line);
 1129:                             if (&hostname($line) ne '') {
 1130:                                 $try_server = $line;
 1131:                                 last;
 1132:                             }
 1133:                         }
 1134:                         close($idf);
 1135:                         if (($try_server) &&
 1136:                             (&has_user_session($try_server,$possudom,$possuname))) {
 1137:                             my $lowest_load = 30000;
 1138:                             ($otherserver,$lowest_load) =
 1139:                                 &compare_server_load($try_server,undef,$lowest_load);
 1140:                             if ($otherserver ne '' && $lowest_load < 100) {
 1141:                                 $has_session = 1;
 1142:                             } else {
 1143:                                 undef($otherserver);
 1144:                             }
 1145:                         }
 1146:                     }
 1147:                 }
 1148:                 if ($has_session) {
 1149:                     if ($update_mtime) {
 1150:                         my $atime = my $mtime = time;
 1151:                         utime($atime,$mtime,"$balancedir/$cookie.id");
 1152:                     }
 1153:                 } else {
 1154:                     unlink("$balancedir/$cookie.id");
 1155:                 }
 1156:             }
 1157:         }
 1158:     }
 1159:     return ($otherserver,$cookie);
 1160: }
 1161: 
 1162: sub updatebalcookie {
 1163:     my ($cookie,$balancer,$lastentry)=@_;
 1164:     if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
 1165:         my ($udom,$uname) = ($1,$2);
 1166:         my $uprimary_id = &domain($udom,'primary');
 1167:         my $uintdom = &internet_dom($uprimary_id);
 1168:         my $intdom = &internet_dom($balancer);
 1169:         my $serverhomedom = &host_domain($balancer);
 1170:         if (($uintdom ne '') && ($uintdom eq $intdom)) {
 1171:             return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer);
 1172:         }
 1173:     }
 1174:     return;
 1175: }
 1176: 
 1177: sub delbalcookie {
 1178:     my ($cookie,$balancer) =@_;
 1179:     if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
 1180:         my ($udom,$uname) = ($1,$2);
 1181:         my $uprimary_id = &domain($udom,'primary');
 1182:         my $uintdom = &internet_dom($uprimary_id);
 1183:         my $intdom = &internet_dom($balancer);
 1184:         my $serverhomedom = &host_domain($balancer);
 1185:         if (($uintdom ne '') && ($uintdom eq $intdom)) {
 1186:             return &reply('delbalcookie:'.&escape($cookie),$balancer);
 1187:         }
 1188:     }
 1189: }
 1190: 
 1191: # -------------------------------- ask if server already has a session for user
 1192: sub has_user_session {
 1193:     my ($lonid,$udom,$uname) = @_;
 1194:     my $result = &reply(join(':','userhassession',
 1195: 			     map {&escape($_)} ($udom,$uname)),$lonid);
 1196:     return 1 if ($result eq 'ok');
 1197: 
 1198:     return 0;
 1199: }
 1200: 
 1201: # --------- determine least loaded server in a user's domain which allows login
 1202: 
 1203: sub choose_server {
 1204:     my ($udom,$checkloginvia,$required,$skiploadbal) = @_;
 1205:     my %domconfhash = &Apache::loncommon::get_domainconf($udom);
 1206:     my %servers = &get_servers($udom);
 1207:     my $lowest_load = 30000;
 1208:     my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
 1209:     if ($skiploadbal) {
 1210:         ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
 1211:         unless (defined($cached)) {
 1212:             my $cachetime = 60*60*24;
 1213:             my %domconfig =
 1214:                 &get_dom('configuration',['loadbalancing'],$udom);
 1215:             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
 1216:                 $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
 1217:                                            $cachetime);
 1218:             }
 1219:         }
 1220:     }
 1221:     foreach my $lonhost (keys(%servers)) {
 1222:         if ($skiploadbal) {
 1223:             if (ref($balancers) eq 'HASH') {
 1224:                 next if (exists($balancers->{$lonhost}));
 1225:             }
 1226:         }
 1227:         my $loginvia;
 1228:         if ($checkloginvia) {
 1229:             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
 1230:             if ($loginvia) {
 1231:                 my ($server,$path) = split(/:/,$loginvia);
 1232:                 ($login_host, $lowest_load) =
 1233:                     &compare_server_load($server, $login_host, $lowest_load, $required);
 1234:                 if ($login_host eq $server) {
 1235:                     $portal_path = $path;
 1236:                     $isredirect = 1;
 1237:                 }
 1238:             } else {
 1239:                 ($login_host, $lowest_load) =
 1240:                     &compare_server_load($lonhost, $login_host, $lowest_load, $required);
 1241:                 if ($login_host eq $lonhost) {
 1242:                     $portal_path = '';
 1243:                     $isredirect = ''; 
 1244:                 }
 1245:             }
 1246:         } else {
 1247:             ($login_host, $lowest_load) =
 1248:                 &compare_server_load($lonhost, $login_host, $lowest_load, $required);
 1249:         }
 1250:     }
 1251:     if ($login_host ne '') {
 1252:         $hostname = &hostname($login_host);
 1253:     }
 1254:     return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
 1255: }
 1256: 
 1257: sub get_course_sessions {
 1258:     my ($cnum,$cdom,$lastactivity) = @_;
 1259:     my %servers = &internet_dom_servers($cdom);
 1260:     my %returnhash;
 1261:     foreach my $server (sort(keys(%servers))) {
 1262:         my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
 1263:         my @pairs=split(/\&/,$rep);
 1264:         unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) {
 1265:             foreach my $item (@pairs) {
 1266:                 my ($key,$value)=split(/=/,$item,2);
 1267:                 $key = &unescape($key);
 1268:                 next if ($key =~ /^error: 2 /);
 1269:                 if (exists($returnhash{$key})) {
 1270:                     next if ($value < $returnhash{$key});
 1271:                 }
 1272:                 $returnhash{$key}=$value;
 1273:             }
 1274:         }
 1275:     }
 1276:     return %returnhash;
 1277: }
 1278: 
 1279: # --------------------------------------------- Try to change a user's password
 1280: 
 1281: sub changepass {
 1282:     my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
 1283:     $currentpass = &escape($currentpass);
 1284:     $newpass     = &escape($newpass);
 1285:     my $lonhost = $perlvar{'lonHostID'};
 1286:     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
 1287: 		       $server);
 1288:     if (! $answer) {
 1289: 	&logthis("No reply on password change request to $server ".
 1290: 		 "by $uname in domain $udom.");
 1291:     } elsif ($answer =~ "^ok") {
 1292:         &logthis("$uname in $udom successfully changed their password ".
 1293: 		 "on $server.");
 1294:     } elsif ($answer =~ "^pwchange_failure") {
 1295: 	&logthis("$uname in $udom was unable to change their password ".
 1296: 		 "on $server.  The action was blocked by either lcpasswd ".
 1297: 		 "or pwchange");
 1298:     } elsif ($answer =~ "^non_authorized") {
 1299:         &logthis("$uname in $udom did not get their password correct when ".
 1300: 		 "attempting to change it on $server.");
 1301:     } elsif ($answer =~ "^auth_mode_error") {
 1302:         &logthis("$uname in $udom attempted to change their password despite ".
 1303: 		 "not being locally or internally authenticated on $server.");
 1304:     } elsif ($answer =~ "^unknown_user") {
 1305:         &logthis("$uname in $udom attempted to change their password ".
 1306: 		 "on $server but were unable to because $server is not ".
 1307: 		 "their home server.");
 1308:     } elsif ($answer =~ "^refused") {
 1309: 	&logthis("$server refused to change $uname in $udom password because ".
 1310: 		 "it was sent an unencrypted request to change the password.");
 1311:     } elsif ($answer =~ "invalid_client") {
 1312:         &logthis("$server refused to change $uname in $udom password because ".
 1313:                  "it was a reset by e-mail originating from an invalid server.");
 1314:     } elsif ($answer =~ "^prioruse") {
 1315:        &logthis("$server refused to change $uname in $udom password because ".
 1316:                 "the password had been used before");
 1317:     }
 1318:     return $answer;
 1319: }
 1320: 
 1321: # ----------------------- Try to determine user's current authentication scheme
 1322: 
 1323: sub queryauthenticate {
 1324:     my ($uname,$udom)=@_;
 1325:     my $uhome=&homeserver($uname,$udom);
 1326:     if ((!$uhome) || ($uhome eq 'no_host')) {
 1327: 	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
 1328: 	return 'no_host';
 1329:     }
 1330:     my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
 1331:     if ($answer =~ /^(unknown_user|refused|con_lost)/) {
 1332: 	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
 1333:     }
 1334:     return $answer;
 1335: }
 1336: 
 1337: # --------- Try to authenticate user from domain's lib servers (first this one)
 1338: 
 1339: sub authenticate {
 1340:     my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_;
 1341:     $upass=&escape($upass);
 1342:     $uname= &LONCAPA::clean_username($uname);
 1343:     my $uhome=&homeserver($uname,$udom,1);
 1344:     my $newhome;
 1345:     if ((!$uhome) || ($uhome eq 'no_host')) {
 1346: # Maybe the machine was offline and only re-appeared again recently?
 1347:         &reconlonc();
 1348: # One more
 1349: 	$uhome=&homeserver($uname,$udom,1);
 1350:         if (($uhome eq 'no_host') && $checkdefauth) {
 1351:             if (defined(&domain($udom,'primary'))) {
 1352:                 $newhome=&domain($udom,'primary');
 1353:             }
 1354:             if ($newhome ne '') {
 1355:                 $uhome = $newhome;
 1356:             }
 1357:         }
 1358: 	if ((!$uhome) || ($uhome eq 'no_host')) {
 1359: 	    &logthis("User $uname at $udom is unknown in authenticate");
 1360: 	    return 'no_host';
 1361:         }
 1362:     }
 1363:     my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome);
 1364:     if ($answer eq 'authorized') {
 1365:         if ($newhome) {
 1366:             &logthis("User $uname at $udom authorized by $uhome, but needs account");
 1367:             return 'no_account_on_host'; 
 1368:         } else {
 1369:             &logthis("User $uname at $udom authorized by $uhome");
 1370:             return $uhome;
 1371:         }
 1372:     }
 1373:     if ($answer eq 'non_authorized') {
 1374: 	&logthis("User $uname at $udom rejected by $uhome");
 1375: 	return 'no_host';
 1376:     }
 1377:     &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
 1378:     return 'no_host';
 1379: }
 1380: 
 1381: sub can_switchserver {
 1382:     my ($udom,$home) = @_;
 1383:     my ($canswitch,@intdoms);
 1384:     my $internet_names = &get_internet_names($home);
 1385:     if (ref($internet_names) eq 'ARRAY') {
 1386:         @intdoms = @{$internet_names};
 1387:     }
 1388:     my $uint_dom = &internet_dom(&domain($udom,'primary'));
 1389:     if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
 1390:         $canswitch = 1;
 1391:     } else {
 1392:          my $serverhomeID = &get_server_homeID(&hostname($home));
 1393:          my $serverhomedom = &host_domain($serverhomeID);
 1394:          my %defdomdefaults = &get_domain_defaults($serverhomedom);
 1395:          my %udomdefaults = &get_domain_defaults($udom);
 1396:          my $remoterev = &get_server_loncaparev('',$home);
 1397:          $canswitch = &can_host_session($udom,$home,$remoterev,
 1398:                                         $udomdefaults{'remotesessions'},
 1399:                                         $defdomdefaults{'hostedsessions'});
 1400:     }
 1401:     return $canswitch;
 1402: }
 1403: 
 1404: sub can_host_session {
 1405:     my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
 1406:     my $canhost = 1;
 1407:     my $host_idn = &internet_dom($lonhost);
 1408:     if (ref($remotesessions) eq 'HASH') {
 1409:         if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
 1410:             if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
 1411:                 $canhost = 0;
 1412:             } else {
 1413:                 $canhost = 1;
 1414:             }
 1415:         }
 1416:         if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') {
 1417:             if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) {
 1418:                 $canhost = 1;
 1419:             } else {
 1420:                 $canhost = 0;
 1421:             }
 1422:         }
 1423:         if ($canhost) {
 1424:             if ($remotesessions->{'version'} ne '') {
 1425:                 my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/);
 1426:                 if ($reqmajor ne '' && $reqminor ne '') {
 1427:                     if ($remoterev =~ /^\'?(\d+)\.(\d+)/) {
 1428:                         my $major = $1;
 1429:                         my $minor = $2;
 1430:                         if (($major < $reqmajor ) ||
 1431:                             (($major == $reqmajor) && ($minor < $reqminor))) {
 1432:                             $canhost = 0;
 1433:                         }
 1434:                     } else {
 1435:                         $canhost = 0;
 1436:                     }
 1437:                 }
 1438:             }
 1439:         }
 1440:     }
 1441:     if ($canhost) {
 1442:         if (ref($hostedsessions) eq 'HASH') {
 1443:             my $uprimary_id = &domain($udom,'primary');
 1444:             my $uint_dom = &internet_dom($uprimary_id);
 1445:             if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
 1446:                 if (($uint_dom ne '') && 
 1447:                     (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
 1448:                     $canhost = 0;
 1449:                 } else {
 1450:                     $canhost = 1;
 1451:                 }
 1452:             }
 1453:             if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
 1454:                 if (($uint_dom ne '') && 
 1455:                     (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {
 1456:                     $canhost = 1;
 1457:                 } else {
 1458:                     $canhost = 0;
 1459:                 }
 1460:             }
 1461:         }
 1462:     }
 1463:     return $canhost;
 1464: }
 1465: 
 1466: sub spare_can_host {
 1467:     my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
 1468:     my $canhost=1;
 1469:     my $try_server_hostname = &hostname($try_server);
 1470:     my $serverhomeID = &get_server_homeID($try_server_hostname);
 1471:     my $serverhomedom = &host_domain($serverhomeID);
 1472:     my %defdomdefaults = &get_domain_defaults($serverhomedom);
 1473:     if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') {
 1474:         if ($defdomdefaults{'offloadnow'}{$try_server}) {
 1475:             $canhost = 0;
 1476:         }
 1477:     }
 1478:     if ($canhost) {
 1479:         if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
 1480:             if ($defdomdefaults{'offloadoth'}{$try_server}) {
 1481:                 unless (&shared_institution($udom,$try_server)) {
 1482:                     $canhost = 0;
 1483:                 }
 1484:             }
 1485:         }
 1486:     }
 1487:     if (($canhost) && ($uint_dom)) {
 1488:         my @intdoms;
 1489:         my $internet_names = &get_internet_names($try_server);
 1490:         if (ref($internet_names) eq 'ARRAY') {
 1491:             @intdoms = @{$internet_names};
 1492:         }
 1493:         unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
 1494:             my $remoterev = &get_server_loncaparev(undef,$try_server);
 1495:             $canhost = &can_host_session($udom,$try_server,$remoterev,
 1496:                                          $remotesessions,
 1497:                                          $defdomdefaults{'hostedsessions'});
 1498:         }
 1499:     }
 1500:     return $canhost;
 1501: }
 1502: 
 1503: sub this_host_spares {
 1504:     my ($dom) = @_;
 1505:     my ($dom_in_use,$lonhost_in_use,$result);
 1506:     my @hosts = &current_machine_ids();
 1507:     foreach my $lonhost (@hosts) {
 1508:         if (&host_domain($lonhost) eq $dom) {
 1509:             $dom_in_use = $dom;
 1510:             $lonhost_in_use = $lonhost;
 1511:             last;
 1512:         }
 1513:     }
 1514:     if ($dom_in_use ne '') {
 1515:         $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
 1516:     }
 1517:     if (ref($result) ne 'HASH') {
 1518:         $lonhost_in_use = $perlvar{'lonHostID'};
 1519:         $dom_in_use = &host_domain($lonhost_in_use);
 1520:         $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
 1521:         if (ref($result) ne 'HASH') {
 1522:             $result = \%spareid;
 1523:         }
 1524:     }
 1525:     return $result;
 1526: }
 1527: 
 1528: sub spares_for_offload  {
 1529:     my ($dom_in_use,$lonhost_in_use) = @_;
 1530:     my ($result,$cached)=&is_cached_new('spares',$dom_in_use);
 1531:     if (defined($cached)) {
 1532:         return $result;
 1533:     } else {
 1534:         my $cachetime = 60*60*24;
 1535:         my %domconfig =
 1536:             &get_dom('configuration',['usersessions'],$dom_in_use);
 1537:         if (ref($domconfig{'usersessions'}) eq 'HASH') {
 1538:             if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
 1539:                 if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
 1540:                     return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime);
 1541:                 }
 1542:             }
 1543:         }
 1544:     }
 1545:     return;
 1546: }
 1547: 
 1548: sub get_lonbalancer_config {
 1549:     my ($servers) = @_;
 1550:     my ($currbalancer,$currtargets);
 1551:     if (ref($servers) eq 'HASH') {
 1552:         foreach my $server (keys(%{$servers})) {
 1553:             my %what = (
 1554:                          spareid => 1,
 1555:                          perlvar => 1,
 1556:                        );
 1557:             my ($result,$returnhash) = &get_remote_globals($server,\%what);
 1558:             if ($result eq 'ok') {
 1559:                 if (ref($returnhash) eq 'HASH') {
 1560:                     if (ref($returnhash->{'perlvar'}) eq 'HASH') {
 1561:                         if ($returnhash->{'perlvar'}->{'lonBalancer'} eq 'yes') {
 1562:                             $currbalancer = $server;
 1563:                             $currtargets = {};
 1564:                             if (ref($returnhash->{'spareid'}) eq 'HASH') {
 1565:                                 if (ref($returnhash->{'spareid'}->{'primary'}) eq 'ARRAY') {
 1566:                                     $currtargets->{'primary'} = $returnhash->{'spareid'}->{'primary'};
 1567:                                 }
 1568:                                 if (ref($returnhash->{'spareid'}->{'default'}) eq 'ARRAY') {
 1569:                                     $currtargets->{'default'} = $returnhash->{'spareid'}->{'default'};
 1570:                                 }
 1571:                             }
 1572:                             last;
 1573:                         }
 1574:                     }
 1575:                 }
 1576:             }
 1577:         }
 1578:     }
 1579:     return ($currbalancer,$currtargets);
 1580: }
 1581: 
 1582: sub check_loadbalancing {
 1583:     my ($uname,$udom,$caller) = @_;
 1584:     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
 1585:         $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
 1586:     my $lonhost = $perlvar{'lonHostID'};
 1587:     my @hosts = &current_machine_ids();
 1588:     my $uprimary_id = &domain($udom,'primary');
 1589:     my $uintdom = &internet_dom($uprimary_id);
 1590:     my $intdom = &internet_dom($lonhost);
 1591:     my $serverhomedom = &host_domain($lonhost);
 1592:     my $domneedscache;
 1593:     my $cachetime = 60*60*24;
 1594: 
 1595:     if (($uintdom ne '') && ($uintdom eq $intdom)) {
 1596:         $dom_in_use = $udom;
 1597:         $homeintdom = 1;
 1598:     } else {
 1599:         $dom_in_use = $serverhomedom;
 1600:     }
 1601:     my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
 1602:     unless (defined($cached)) {
 1603:         my %domconfig =
 1604:             &get_dom('configuration',['loadbalancing'],$dom_in_use);
 1605:         if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
 1606:             $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
 1607:         } else {
 1608:             $domneedscache = $dom_in_use;
 1609:         }
 1610:     }
 1611:     if (ref($result) eq 'HASH') {
 1612:         ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
 1613:             &check_balancer_result($result,@hosts);
 1614:         if ($is_balancer) {
 1615:             if (ref($currrules) eq 'HASH') {
 1616:                 if ($homeintdom) {
 1617:                     if ($uname ne '') {
 1618:                         if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) {
 1619:                             my ($is_adv,$is_author) = &is_advanced_user($udom,$uname);
 1620:                             if (($currrules->{'_LC_author'} ne '') && ($is_author)) {
 1621:                                 $rule_in_effect = $currrules->{'_LC_author'};
 1622:                             } elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) {
 1623:                                 $rule_in_effect = $currrules->{'_LC_adv'}
 1624:                             }
 1625:                         }
 1626:                         if ($rule_in_effect eq '') {
 1627:                             my %userenv = &userenvironment($udom,$uname,'inststatus');
 1628:                             if ($userenv{'inststatus'} ne '') {
 1629:                                 my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'});
 1630:                                 my ($othertitle,$usertypes,$types) =
 1631:                                     &Apache::loncommon::sorted_inst_types($udom);
 1632:                                 if (ref($types) eq 'ARRAY') {
 1633:                                     foreach my $type (@{$types}) {
 1634:                                         if (grep(/^\Q$type\E$/,@statuses)) {
 1635:                                             if (exists($currrules->{$type})) {
 1636:                                                 $rule_in_effect = $currrules->{$type};
 1637:                                             }
 1638:                                         }
 1639:                                     }
 1640:                                 }
 1641:                             } else {
 1642:                                 if (exists($currrules->{'default'})) {
 1643:                                     $rule_in_effect = $currrules->{'default'};
 1644:                                 }
 1645:                             }
 1646:                         }
 1647:                     } else {
 1648:                         if (exists($currrules->{'default'})) {
 1649:                             $rule_in_effect = $currrules->{'default'};
 1650:                         }
 1651:                     }
 1652:                 } else {
 1653:                     if ($currrules->{'_LC_external'} ne '') {
 1654:                         $rule_in_effect = $currrules->{'_LC_external'};
 1655:                     }
 1656:                 }
 1657:                 $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
 1658:                                                        $uname,$udom);
 1659:             }
 1660:         }
 1661:     } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
 1662:         ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
 1663:         unless (defined($cached)) {
 1664:             my %domconfig =
 1665:                 &get_dom('configuration',['loadbalancing'],$serverhomedom);
 1666:             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
 1667:                 $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
 1668:             } else {
 1669:                 $domneedscache = $serverhomedom;
 1670:             }
 1671:         }
 1672:         if (ref($result) eq 'HASH') {
 1673:             ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
 1674:                 &check_balancer_result($result,@hosts);
 1675:             if ($is_balancer) {
 1676:                 if (ref($currrules) eq 'HASH') {
 1677:                     if ($currrules->{'_LC_internetdom'} ne '') {
 1678:                         $rule_in_effect = $currrules->{'_LC_internetdom'};
 1679:                     }
 1680:                 }
 1681:                 $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
 1682:                                                        $uname,$udom);
 1683:             }
 1684:         } else {
 1685:             if ($perlvar{'lonBalancer'} eq 'yes') {
 1686:                 $is_balancer = 1;
 1687:                 $offloadto = &this_host_spares($dom_in_use);
 1688:             }
 1689:             unless (defined($cached)) {
 1690:                 $domneedscache = $serverhomedom;
 1691:             }
 1692:         }
 1693:     } else {
 1694:         if ($perlvar{'lonBalancer'} eq 'yes') {
 1695:             $is_balancer = 1;
 1696:             $offloadto = &this_host_spares($dom_in_use);
 1697:         }
 1698:         unless (defined($cached)) {
 1699:             $domneedscache = $serverhomedom;
 1700:         }
 1701:     }
 1702:     if ($domneedscache) {
 1703:         &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
 1704:     }
 1705:     if (($is_balancer) && ($caller ne 'switchserver')) {
 1706:         my $lowest_load = 30000;
 1707:         if (ref($offloadto) eq 'HASH') {
 1708:             if (ref($offloadto->{'primary'}) eq 'ARRAY') {
 1709:                 foreach my $try_server (@{$offloadto->{'primary'}}) {
 1710:                     ($otherserver,$lowest_load) =
 1711:                         &compare_server_load($try_server,$otherserver,$lowest_load);
 1712:                 }
 1713:             }
 1714:             my $found_server = ($otherserver ne '' && $lowest_load < 100);
 1715: 
 1716:             if (!$found_server) {
 1717:                 if (ref($offloadto->{'default'}) eq 'ARRAY') {
 1718:                     foreach my $try_server (@{$offloadto->{'default'}}) {
 1719:                         ($otherserver,$lowest_load) =
 1720:                             &compare_server_load($try_server,$otherserver,$lowest_load);
 1721:                     }
 1722:                 }
 1723:             }
 1724:         } elsif (ref($offloadto) eq 'ARRAY') {
 1725:             if (@{$offloadto} == 1) {
 1726:                 $otherserver = $offloadto->[0];
 1727:             } elsif (@{$offloadto} > 1) {
 1728:                 foreach my $try_server (@{$offloadto}) {
 1729:                     ($otherserver,$lowest_load) =
 1730:                         &compare_server_load($try_server,$otherserver,$lowest_load);
 1731:                 }
 1732:             }
 1733:         }
 1734:         unless ($caller eq 'login') {
 1735:             if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
 1736:                 $is_balancer = 0;
 1737:                 if ($uname ne '' && $udom ne '') {
 1738:                     if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
 1739:                         &appenv({'user.loadbalexempt'     => $lonhost,
 1740:                                  'user.loadbalcheck.time' => time});
 1741:                     }
 1742:                 }
 1743:             }
 1744:         }
 1745:     }
 1746:     if (($is_balancer) && (!$homeintdom)) {
 1747:         undef($setcookie);
 1748:     }
 1749:     return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
 1750: }
 1751: 
 1752: sub check_balancer_result {
 1753:     my ($result,@hosts) = @_;
 1754:     my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
 1755:     if (ref($result) eq 'HASH') {
 1756:         if ($result->{'lonhost'} ne '') {
 1757:             my $currbalancer = $result->{'lonhost'};
 1758:             if (grep(/^\Q$currbalancer\E$/,@hosts)) {
 1759:                 $is_balancer = 1;
 1760:                 $currtargets = $result->{'targets'};
 1761:                 $currrules = $result->{'rules'};
 1762:             }
 1763:             $dom_balancers = $currbalancer;
 1764:         } else {
 1765:             if (keys(%{$result})) {
 1766:                 foreach my $key (keys(%{$result})) {
 1767:                     if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
 1768:                         (ref($result->{$key}) eq 'HASH')) {
 1769:                         $is_balancer = 1;
 1770:                         $currrules = $result->{$key}{'rules'};
 1771:                         $currtargets = $result->{$key}{'targets'};
 1772:                         $setcookie = $result->{$key}{'cookie'};
 1773:                         last;
 1774:                     }
 1775:                 }
 1776:                 $dom_balancers = join(',',sort(keys(%{$result})));
 1777:             }
 1778:         }
 1779:     }
 1780:     return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
 1781: }
 1782: 
 1783: sub get_loadbalancer_targets {
 1784:     my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
 1785:     my $offloadto;
 1786:     if ($rule_in_effect eq 'none') {
 1787:         return [$perlvar{'lonHostID'}];
 1788:     } elsif ($rule_in_effect eq '') {
 1789:         $offloadto = $currtargets;
 1790:     } else {
 1791:         if ($rule_in_effect eq 'homeserver') {
 1792:             my $homeserver = &homeserver($uname,$udom);
 1793:             if ($homeserver ne 'no_host') {
 1794:                 $offloadto = [$homeserver];
 1795:             }
 1796:         } elsif ($rule_in_effect eq 'externalbalancer') {
 1797:             my %domconfig =
 1798:                 &get_dom('configuration',['loadbalancing'],$udom);
 1799:             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
 1800:                 if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
 1801:                     if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
 1802:                         $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}];
 1803:                     }
 1804:                 }
 1805:             } else {
 1806:                 my %servers = &internet_dom_servers($udom);
 1807:                 my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
 1808:                 if (&hostname($remotebalancer) ne '') {
 1809:                     $offloadto = [$remotebalancer];
 1810:                 }
 1811:             }
 1812:         } elsif (&hostname($rule_in_effect) ne '') {
 1813:             $offloadto = [$rule_in_effect];
 1814:         }
 1815:     }
 1816:     return $offloadto;
 1817: }
 1818: 
 1819: sub internet_dom_servers {
 1820:     my ($dom) = @_;
 1821:     my (%uniqservers,%servers);
 1822:     my $primaryserver = &hostname(&domain($dom,'primary'));
 1823:     my @machinedoms = &machine_domains($primaryserver);
 1824:     foreach my $mdom (@machinedoms) {
 1825:         my %currservers = %servers;
 1826:         my %server = &get_servers($mdom);
 1827:         %servers = (%currservers,%server);
 1828:     }
 1829:     my %by_hostname;
 1830:     foreach my $id (keys(%servers)) {
 1831:         push(@{$by_hostname{$servers{$id}}},$id);
 1832:     }
 1833:     foreach my $hostname (sort(keys(%by_hostname))) {
 1834:         if (@{$by_hostname{$hostname}} > 1) {
 1835:             my $match = 0;
 1836:             foreach my $id (@{$by_hostname{$hostname}}) {
 1837:                 if (&host_domain($id) eq $dom) {
 1838:                     $uniqservers{$id} = $hostname;
 1839:                     $match = 1;
 1840:                 }
 1841:             }
 1842:             unless ($match) {
 1843:                 $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
 1844:             }
 1845:         } else {
 1846:             $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
 1847:         }
 1848:     }
 1849:     return %uniqservers;
 1850: }
 1851: 
 1852: sub trusted_domains {
 1853:     my ($cmdtype,$calldom) = @_;
 1854:     my ($trusted,$untrusted);
 1855:     if (&domain($calldom) eq '') {
 1856:         return ($trusted,$untrusted);
 1857:     }
 1858:     unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) {
 1859:         return ($trusted,$untrusted);
 1860:     }
 1861:     my $callprimary = &domain($calldom,'primary');
 1862:     my $intcalldom = &internet_dom($callprimary);
 1863:     if ($intcalldom eq '') {
 1864:         return ($trusted,$untrusted);
 1865:     }
 1866: 
 1867:     my ($trustconfig,$cached)=&is_cached_new('trust',$calldom);
 1868:     unless (defined($cached)) {
 1869:         my %domconfig = &get_dom('configuration',['trust'],$calldom);
 1870:         &do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
 1871:         $trustconfig = $domconfig{'trust'};
 1872:     }
 1873:     if (ref($trustconfig)) {
 1874:         my (%possexc,%possinc,@allexc,@allinc); 
 1875:         if (ref($trustconfig->{$cmdtype}) eq 'HASH') {
 1876:             if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') {
 1877:                 map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; 
 1878:             }
 1879:             if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
 1880:                 $possinc{$intcalldom} = 1;
 1881:                 map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
 1882:             }
 1883:         }
 1884:         if (keys(%possexc)) {
 1885:             if (keys(%possinc)) {
 1886:                 foreach my $key (sort(keys(%possexc))) {
 1887:                     next if ($key eq $intcalldom);
 1888:                     unless ($possinc{$key}) {
 1889:                         push(@allexc,$key);
 1890:                     }
 1891:                 }
 1892:             } else {
 1893:                 @allexc = sort(keys(%possexc));
 1894:             }
 1895:         }
 1896:         if (keys(%possinc)) {
 1897:             $possinc{$intcalldom} = 1;
 1898:             @allinc = sort(keys(%possinc));
 1899:         }
 1900:         if ((@allexc > 0) || (@allinc > 0)) {
 1901:             my %doms_by_intdom;
 1902:             my %allintdoms = &all_host_intdom();
 1903:             my %alldoms = &all_host_domain();
 1904:             foreach my $key (%allintdoms) {
 1905:                 if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') {
 1906:                     unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) {
 1907:                         push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key});
 1908:                     }
 1909:                 } else {
 1910:                     $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}]; 
 1911:                 }
 1912:             }
 1913:             foreach my $exc (@allexc) {
 1914:                 if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
 1915:                     push(@{$untrusted},@{$doms_by_intdom{$exc}});
 1916:                 }
 1917:             }
 1918:             foreach my $inc (@allinc) {
 1919:                 if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
 1920:                     push(@{$trusted},@{$doms_by_intdom{$inc}});
 1921:                 }
 1922:             }
 1923:         }
 1924:     }
 1925:     return ($trusted,$untrusted);
 1926: }
 1927: 
 1928: sub will_trust {
 1929:     my ($cmdtype,$domain,$possdom) = @_;
 1930:     return 1 if ($domain eq $possdom);
 1931:     my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom);
 1932:     my $willtrust; 
 1933:     if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) {
 1934:         if (grep(/^\Q$domain\E$/,@{$trustedref})) {
 1935:             $willtrust = 1;
 1936:         }
 1937:     } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) {
 1938:         unless (grep(/^\Q$domain\E$/,@{$untrustedref})) {
 1939:             $willtrust = 1;
 1940:         }
 1941:     } else {
 1942:         $willtrust = 1;
 1943:     }
 1944:     return $willtrust;
 1945: }
 1946: 
 1947: # ---------------------- Find the homebase for a user from domain's lib servers
 1948: 
 1949: my %homecache;
 1950: sub homeserver {
 1951:     my ($uname,$udom,$ignoreBadCache)=@_;
 1952:     my $index="$uname:$udom";
 1953: 
 1954:     if (exists($homecache{$index})) { return $homecache{$index}; }
 1955: 
 1956:     my %servers = &get_servers($udom,'library');
 1957:     foreach my $tryserver (keys(%servers)) {
 1958:         next if ($ignoreBadCache ne 'true' && 
 1959: 		 exists($badServerCache{$tryserver}));
 1960: 
 1961: 	my $answer=reply("home:$udom:$uname",$tryserver);
 1962: 	if ($answer eq 'found') {
 1963: 	    delete($badServerCache{$tryserver}); 
 1964: 	    return $homecache{$index}=$tryserver;
 1965: 	} elsif ($answer eq 'no_host') {
 1966: 	    $badServerCache{$tryserver}=1;
 1967: 	}
 1968:     }    
 1969:     return 'no_host';
 1970: }
 1971: 
 1972: # ----- Find the usernames behind a list of student/employee IDs or clicker IDs
 1973: 
 1974: sub idget {
 1975:     my ($udom,$idsref,$namespace)=@_;
 1976:     my %returnhash=();
 1977:     my @ids=(); 
 1978:     if (ref($idsref) eq 'ARRAY') {
 1979:         @ids = @{$idsref};
 1980:     } else {
 1981:         return %returnhash; 
 1982:     }
 1983:     if ($namespace eq '') {
 1984:         $namespace = 'ids';
 1985:     }
 1986:     
 1987:     my %servers = &get_servers($udom,'library');
 1988:     foreach my $tryserver (keys(%servers)) {
 1989: 	my $idlist=join('&', map { &escape($_); } @ids);
 1990: 	if ($namespace eq 'ids') {
 1991: 	    $idlist=~tr/A-Z/a-z/;
 1992: 	}
 1993: 	my $reply;
 1994: 	if ($namespace eq 'ids') {
 1995: 	    $reply=&reply("idget:$udom:".$idlist,$tryserver);
 1996: 	} else {
 1997: 	    $reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver);
 1998: 	}
 1999: 	my @answer=();
 2000: 	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
 2001: 	    @answer=split(/\&/,$reply);
 2002: 	}                    ;
 2003: 	my $i;
 2004: 	for ($i=0;$i<=$#ids;$i++) {
 2005: 	    if ($answer[$i]) {
 2006: 		$returnhash{$ids[$i]}=&unescape($answer[$i]);
 2007: 	    }
 2008: 	}
 2009:     }
 2010:     return %returnhash;
 2011: }
 2012: 
 2013: # ------------------------------------- Find the IDs behind a list of usernames
 2014: 
 2015: sub idrget {
 2016:     my ($udom,@unames)=@_;
 2017:     my %returnhash=();
 2018:     foreach my $uname (@unames) {
 2019:         $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
 2020:     }
 2021:     return %returnhash;
 2022: }
 2023: 
 2024: # Store away a list of names and associated student/employee IDs or clicker IDs
 2025: 
 2026: sub idput {
 2027:     my ($udom,$idsref,$uhom,$namespace)=@_;
 2028:     my %servers=();
 2029:     my %ids=();
 2030:     my %byid = ();
 2031:     if (ref($idsref) eq 'HASH') {
 2032:         %ids=%{$idsref};
 2033:     }
 2034:     if ($namespace eq '') {
 2035:         $namespace = 'ids'; 
 2036:     }
 2037:     foreach my $uname (keys(%ids)) {
 2038: 	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
 2039:         if ($uhom eq '') {
 2040:             $uhom=&homeserver($uname,$udom);
 2041:         }
 2042:         if ($uhom ne 'no_host') {
 2043:             my $esc_unam=&escape($uname);
 2044:             if ($namespace eq 'ids') {
 2045:                 my $id=&escape($ids{$uname});
 2046:                 $id=~tr/A-Z/a-z/;
 2047:                 my $esc_unam=&escape($uname);
 2048:                 $servers{$uhom}.=$id.'='.$esc_unam.'&';
 2049:             } else {
 2050:                 my @currids = split(/,/,$ids{$uname});
 2051:                 foreach my $id (@currids) {
 2052:                     $byid{$uhom}{$id} .= $uname.',';
 2053:                 }
 2054:             }
 2055:         }
 2056:     }
 2057:     if ($namespace eq 'clickers') {
 2058:         foreach my $server (keys(%byid)) {
 2059:             if (ref($byid{$server}) eq 'HASH') {
 2060:                 foreach my $id (keys(%{$byid{$server}})) {
 2061:                     $byid{$server} =~ s/,$//;
 2062:                     $servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&'; 
 2063:                 }
 2064:             }
 2065:         }
 2066:     }
 2067:     foreach my $server (keys(%servers)) {
 2068:         $servers{$server} =~ s/\&$//;
 2069:         if ($namespace eq 'ids') {     
 2070:             &critical('idput:'.$udom.':'.$servers{$server},$server);
 2071:         } else {
 2072:             &critical('updateclickers:'.$udom.':add:'.$servers{$server},$server);
 2073:         }
 2074:     }
 2075: }
 2076: 
 2077: # ------------- Delete unwanted student/employee IDs or clicker IDs from domain
 2078: 
 2079: sub iddel {
 2080:     my ($udom,$idshashref,$uhome,$namespace)=@_;
 2081:     my %result=();
 2082:     my %ids=();
 2083:     my %byid = ();
 2084:     if (ref($idshashref) eq 'HASH') {
 2085:         %ids=%{$idshashref};
 2086:     } else {
 2087:         return %result;
 2088:     }
 2089:     if ($namespace eq '') {
 2090:         $namespace = 'ids';
 2091:     }
 2092:     my %servers=();
 2093:     while (my ($id,$unamestr) = each(%ids)) {
 2094:         if ($namespace eq 'ids') {
 2095:             my $uhom = $uhome;
 2096:             if ($uhom eq '') { 
 2097:                 $uhom=&homeserver($unamestr,$udom);
 2098:             }
 2099:             if ($uhom ne 'no_host') {
 2100:                 $servers{$uhom}.='&'.&escape($id);
 2101:             }
 2102:          } else {
 2103:             my @curritems = split(/,/,$ids{$id});
 2104:             foreach my $uname (@curritems) {
 2105:                 my $uhom = $uhome;
 2106:                 if ($uhom eq '') {
 2107:                     $uhom=&homeserver($uname,$udom);
 2108:                 }
 2109:                 if ($uhom ne 'no_host') { 
 2110:                     $byid{$uhom}{$id} .= $uname.',';
 2111:                 }
 2112:             }
 2113:         }
 2114:     }
 2115:     if ($namespace eq 'clickers') {
 2116:         foreach my $server (keys(%byid)) {
 2117:             if (ref($byid{$server}) eq 'HASH') {
 2118:                 foreach my $id (keys(%{$byid{$server}})) {
 2119:                     $byid{$server}{$id} =~ s/,$//;
 2120:                     $servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&';
 2121:                 }
 2122:             }
 2123:         }
 2124:     }
 2125:     foreach my $server (keys(%servers)) {
 2126:         $servers{$server} =~ s/\&$//;
 2127:         if ($namespace eq 'ids') {
 2128:             $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
 2129:         } elsif ($namespace eq 'clickers') {
 2130:             $result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server);
 2131:         }
 2132:     }
 2133:     return %result;
 2134: }
 2135: 
 2136: # ----- Update clicker ID-to-username look-ups in clickers.db on library server 
 2137: 
 2138: sub updateclickers {
 2139:     my ($udom,$action,$idshashref,$uhome,$critical) = @_;
 2140:     my %clickers;
 2141:     if (ref($idshashref) eq 'HASH') {
 2142:         %clickers=%{$idshashref};
 2143:     } else {
 2144:         return;
 2145:     }
 2146:     my $items='';
 2147:     foreach my $item (keys(%clickers)) {
 2148:         $items.=&escape($item).'='.&escape($clickers{$item}).'&';
 2149:     }
 2150:     $items=~s/\&$//;
 2151:     my $request = "updateclickers:$udom:$action:$items";
 2152:     if ($critical) {
 2153:         return &critical($request,$uhome);
 2154:     } else {
 2155:         return &reply($request,$uhome);
 2156:     }
 2157: }
 2158: 
 2159: # ------------------------------dump from db file owned by domainconfig user
 2160: sub dump_dom {
 2161:     my ($namespace, $udom, $regexp) = @_;
 2162: 
 2163:     $udom ||= $env{'user.domain'};
 2164: 
 2165:     return () unless $udom;
 2166: 
 2167:     return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
 2168: }
 2169: 
 2170: # ------------------------------------------ get items from domain db files   
 2171: 
 2172: sub get_dom {
 2173:     my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
 2174:     return if ($udom eq 'public');
 2175:     my $items='';
 2176:     foreach my $item (@$storearr) {
 2177:         $items.=&escape($item).'&';
 2178:     }
 2179:     $items=~s/\&$//;
 2180:     if (!$udom) {
 2181:         $udom=$env{'user.domain'};
 2182:         return if ($udom eq 'public');
 2183:         if (defined(&domain($udom,'primary'))) {
 2184:             $uhome=&domain($udom,'primary');
 2185:         } else {
 2186:             undef($uhome);
 2187:         }
 2188:     } else {
 2189:         if (!$uhome) {
 2190:             if (defined(&domain($udom,'primary'))) {
 2191:                 $uhome=&domain($udom,'primary');
 2192:             }
 2193:         }
 2194:     }
 2195:     if ($udom && $uhome && ($uhome ne 'no_host')) {
 2196:         my $rep;
 2197:         if (grep { $_ eq $uhome } &current_machine_ids()) {
 2198:             # domain information is hosted on this machine
 2199:             $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
 2200:         } else {
 2201:             if ($encrypt) {
 2202:                 $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
 2203:             } else {
 2204:                 $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
 2205:             }
 2206:         }
 2207:         my %returnhash;
 2208:         if ($rep eq '' || $rep =~ /^error: 2 /) {
 2209:             return %returnhash;
 2210:         }
 2211:         my @pairs=split(/\&/,$rep);
 2212:         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
 2213:             return @pairs;
 2214:         }
 2215:         my $i=0;
 2216:         foreach my $item (@$storearr) {
 2217:             $returnhash{$item}=&thaw_unescape($pairs[$i]);
 2218:             $i++;
 2219:         }
 2220:         return %returnhash;
 2221:     } else {
 2222:         &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
 2223:     }
 2224: }
 2225: 
 2226: # -------------------------------------------- put items in domain db files 
 2227: 
 2228: sub put_dom {
 2229:     my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
 2230:     if (!$udom) {
 2231:         $udom=$env{'user.domain'};
 2232:         if (defined(&domain($udom,'primary'))) {
 2233:             $uhome=&domain($udom,'primary');
 2234:         } else {
 2235:             undef($uhome);
 2236:         }
 2237:     } else {
 2238:         if (!$uhome) {
 2239:             if (defined(&domain($udom,'primary'))) {
 2240:                 $uhome=&domain($udom,'primary');
 2241:             }
 2242:         }
 2243:     } 
 2244:     if ($udom && $uhome && ($uhome ne 'no_host')) {
 2245:         my $items='';
 2246:         foreach my $item (keys(%$storehash)) {
 2247:             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 2248:         }
 2249:         $items=~s/\&$//;
 2250:         if ($encrypt) {
 2251:             return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
 2252:         } else {
 2253:             return &reply("putdom:$udom:$namespace:$items",$uhome);
 2254:         }
 2255:     } else {
 2256:         &logthis("put_dom failed - no homeserver and/or domain");
 2257:     }
 2258: }
 2259: 
 2260: # --------------------- newput for items in db file owned by domainconfig user
 2261: sub newput_dom {
 2262:     my ($namespace,$storehash,$udom) = @_;
 2263:     my $result;
 2264:     if (!$udom) {
 2265:         $udom=$env{'user.domain'};
 2266:     }
 2267:     if ($udom) {
 2268:         my $uname = &get_domainconfiguser($udom);
 2269:         $result = &newput($namespace,$storehash,$udom,$uname);
 2270:     }
 2271:     return $result;
 2272: }
 2273: 
 2274: # --------------------- delete for items in db file owned by domainconfig user
 2275: sub del_dom {
 2276:     my ($namespace,$storearr,$udom)=@_;
 2277:     if (ref($storearr) eq 'ARRAY') {
 2278:         if (!$udom) {
 2279:             $udom=$env{'user.domain'};
 2280:         }
 2281:         if ($udom) {
 2282:             my $uname = &get_domainconfiguser($udom); 
 2283:             return &del($namespace,$storearr,$udom,$uname);
 2284:         }
 2285:     }
 2286: }
 2287: 
 2288: sub store_dom {
 2289:     my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_;
 2290:     $$storehash{'ip'}=&get_requestor_ip();
 2291:     $$storehash{'host'}=$perlvar{'lonHostID'};
 2292:     my $namevalue='';
 2293:     foreach my $key (keys(%{$storehash})) {
 2294:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 2295:     }
 2296:     $namevalue=~s/\&$//;
 2297:     if (grep { $_ eq $home } current_machine_ids()) {
 2298:         return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue");
 2299:     } else {
 2300:         if ($namespace eq 'private') {
 2301:             return 'refused';
 2302:         } elsif ($encrypt) {
 2303:             return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home);
 2304:         } else {
 2305:             return reply("storedom:$dom:$namespace:$id:$namevalue",$home);
 2306:         }
 2307:     }
 2308: }
 2309: 
 2310: sub restore_dom {
 2311:     my ($id,$namespace,$dom,$home,$encrypt) = @_;
 2312:     my $answer;
 2313:     if (grep { $_ eq $home } current_machine_ids()) {
 2314:         $answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id");
 2315:     } elsif ($namespace ne 'private') {
 2316:         if ($encrypt) {
 2317:             $answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home);
 2318:         } else {
 2319:             $answer=&reply("restoredom:$dom:$namespace:$id",$home);
 2320:         }
 2321:     }
 2322:     my %returnhash=();
 2323:     unless (($answer eq '') || ($answer eq 'con_lost') || ($answer eq 'refused') || 
 2324:             ($answer eq 'unknown_cmd') || ($answer eq 'rejected')) {
 2325:         foreach my $line (split(/\&/,$answer)) {
 2326:             my ($name,$value)=split(/\=/,$line);
 2327:             $returnhash{&unescape($name)}=&thaw_unescape($value);
 2328:         }
 2329:         my $version;
 2330:         for ($version=1;$version<=$returnhash{'version'};$version++) {
 2331:             foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
 2332:                 $returnhash{$item}=$returnhash{$version.':'.$item};
 2333:             }
 2334:         }
 2335:     }
 2336:     return %returnhash;
 2337: }
 2338: 
 2339: # ----------------------------------construct domainconfig user for a domain 
 2340: sub get_domainconfiguser {
 2341:     my ($udom) = @_;
 2342:     return $udom.'-domainconfig';
 2343: }
 2344: 
 2345: sub retrieve_inst_usertypes {
 2346:     my ($udom) = @_;
 2347:     my (%returnhash,@order);
 2348:     my %domdefs = &get_domain_defaults($udom);
 2349:     if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
 2350:         (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
 2351:         return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
 2352:     } else {
 2353:         if (defined(&domain($udom,'primary'))) {
 2354:             my $uhome=&domain($udom,'primary');
 2355:             my $rep=&reply("inst_usertypes:$udom",$uhome);
 2356:             if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
 2357:                 &logthis("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom");
 2358:                 return (\%returnhash,\@order);
 2359:             }
 2360:             my ($hashitems,$orderitems) = split(/:/,$rep); 
 2361:             my @pairs=split(/\&/,$hashitems);
 2362:             foreach my $item (@pairs) {
 2363:                 my ($key,$value)=split(/=/,$item,2);
 2364:                 $key = &unescape($key);
 2365:                 next if ($key =~ /^error: 2 /);
 2366:                 $returnhash{$key}=&thaw_unescape($value);
 2367:             }
 2368:             my @esc_order = split(/\&/,$orderitems);
 2369:             foreach my $item (@esc_order) {
 2370:                 push(@order,&unescape($item));
 2371:             }
 2372:         } else {
 2373:             &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom");
 2374:         }
 2375:         return (\%returnhash,\@order);
 2376:     }
 2377: }
 2378: 
 2379: sub is_domainimage {
 2380:     my ($url) = @_;
 2381:     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo|login)/+[^/]-) {
 2382:         if (&domain($1) ne '') {
 2383:             return '1';
 2384:         }
 2385:     }
 2386:     return;
 2387: }
 2388: 
 2389: sub inst_directory_query {
 2390:     my ($srch) = @_;
 2391:     my $udom = $srch->{'srchdomain'};
 2392:     my %results;
 2393:     my $homeserver = &domain($udom,'primary');
 2394:     my $outcome;
 2395:     if ($homeserver ne '') {
 2396:         unless ($homeserver eq $perlvar{'lonHostID'}) {
 2397:             if ($srch->{'srchby'} eq 'email') {
 2398:                 my $lcrev = &get_server_loncaparev($udom,$homeserver);
 2399:                 my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
 2400:                 if (($major eq '' && $minor eq '') || ($major < 2) ||
 2401:                     (($major == 2) && ($minor < 12))) {
 2402:                     return;
 2403:                 }
 2404:             }
 2405:         }
 2406: 	my $queryid=&reply("querysend:instdirsearch:".
 2407: 			   &escape($srch->{'srchby'}).':'.
 2408: 			   &escape($srch->{'srchterm'}).':'.
 2409: 			   &escape($srch->{'srchtype'}),$homeserver);
 2410: 	my $host=&hostname($homeserver);
 2411: 	if ($queryid !~/^\Q$host\E\_/) {
 2412: 	    &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom);
 2413: 	    return;
 2414: 	}
 2415: 	my $response = &get_query_reply($queryid);
 2416: 	my $maxtries = 5;
 2417: 	my $tries = 1;
 2418: 	while (($response=~/^timeout/) && ($tries < $maxtries)) {
 2419: 	    $response = &get_query_reply($queryid);
 2420: 	    $tries ++;
 2421: 	}
 2422: 
 2423:         if (!&error($response) && $response ne 'refused') {
 2424:             if ($response eq 'unavailable') {
 2425:                 $outcome = $response;
 2426:             } else {
 2427:                 $outcome = 'ok';
 2428:                 my @matches = split(/\n/,$response);
 2429:                 foreach my $match (@matches) {
 2430:                     my ($key,$value) = split(/=/,$match);
 2431:                     $results{&unescape($key).':'.$udom} = &thaw_unescape($value);
 2432:                 }
 2433:             }
 2434:         }
 2435:     }
 2436:     return ($outcome,%results);
 2437: }
 2438: 
 2439: sub usersearch {
 2440:     my ($srch) = @_;
 2441:     my $dom = $srch->{'srchdomain'};
 2442:     my %results;
 2443:     my %libserv = &all_library();
 2444:     my $query = 'usersearch';
 2445:     foreach my $tryserver (keys(%libserv)) {
 2446:         if (&host_domain($tryserver) eq $dom) {
 2447:             unless ($tryserver eq $perlvar{'lonHostID'}) {
 2448:                 if ($srch->{'srchby'} eq 'email') {
 2449:                     my $lcrev = &get_server_loncaparev($dom,$tryserver);
 2450:                     my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
 2451:                     next if (($major eq '' && $minor eq '') || ($major < 2) ||
 2452:                              (($major == 2) && ($minor < 12)));
 2453:                 }
 2454:             }
 2455:             my $host=&hostname($tryserver);
 2456:             my $queryid=
 2457:                 &reply("querysend:".&escape($query).':'.
 2458:                        &escape($srch->{'srchby'}).':'.
 2459:                        &escape($srch->{'srchtype'}).':'.
 2460:                        &escape($srch->{'srchterm'}),$tryserver);
 2461:             if ($queryid !~/^\Q$host\E\_/) {
 2462:                 &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
 2463:                 next;
 2464:             }
 2465:             my $reply = &get_query_reply($queryid);
 2466:             my $maxtries = 1;
 2467:             my $tries = 1;
 2468:             while (($reply=~/^timeout/) && ($tries < $maxtries)) {
 2469:                 $reply = &get_query_reply($queryid);
 2470:                 $tries ++;
 2471:             }
 2472:             if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
 2473:                 &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);
 2474:             } else {
 2475:                 my @matches;
 2476:                 if ($reply =~ /\n/) {
 2477:                     @matches = split(/\n/,$reply);
 2478:                 } else {
 2479:                     @matches = split(/\&/,$reply);
 2480:                 }
 2481:                 foreach my $match (@matches) {
 2482:                     my ($uname,$udom,%userhash);
 2483:                     foreach my $entry (split(/:/,$match)) {
 2484:                         my ($key,$value) =
 2485:                             map {&unescape($_);} split(/=/,$entry);
 2486:                         $userhash{$key} = $value;
 2487:                         if ($key eq 'username') {
 2488:                             $uname = $value;
 2489:                         } elsif ($key eq 'domain') {
 2490:                             $udom = $value;
 2491:                         }
 2492:                     }
 2493:                     $results{$uname.':'.$udom} = \%userhash;
 2494:                 }
 2495:             }
 2496:         }
 2497:     }
 2498:     return %results;
 2499: }
 2500: 
 2501: sub get_instuser {
 2502:     my ($udom,$uname,$id) = @_;
 2503:     my $homeserver = &domain($udom,'primary');
 2504:     my ($outcome,%results);
 2505:     if ($homeserver ne '') {
 2506:         my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
 2507:                            &escape($id).':'.&escape($udom),$homeserver);
 2508:         my $host=&hostname($homeserver);
 2509:         if ($queryid !~/^\Q$host\E\_/) {
 2510:             &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
 2511:             return;
 2512:         }
 2513:         my $response = &get_query_reply($queryid);
 2514:         my $maxtries = 5;
 2515:         my $tries = 1;
 2516:         while (($response=~/^timeout/) && ($tries < $maxtries)) {
 2517:             $response = &get_query_reply($queryid);
 2518:             $tries ++;
 2519:         }
 2520:         if (!&error($response) && $response ne 'refused') {
 2521:             if ($response eq 'unavailable') {
 2522:                 $outcome = $response;
 2523:             } else {
 2524:                 $outcome = 'ok';
 2525:                 my @matches = split(/\n/,$response);
 2526:                 foreach my $match (@matches) {
 2527:                     my ($key,$value) = split(/=/,$match);
 2528:                     $results{&unescape($key)} = &thaw_unescape($value);
 2529:                 }
 2530:             }
 2531:         }
 2532:     }
 2533:     my %userinfo;
 2534:     if (ref($results{$uname}) eq 'HASH') {
 2535:         %userinfo = %{$results{$uname}};
 2536:     } 
 2537:     return ($outcome,%userinfo);
 2538: }
 2539: 
 2540: sub get_multiple_instusers {
 2541:     my ($udom,$users,$caller) = @_;
 2542:     my ($outcome,$results);
 2543:     if (ref($users) eq 'HASH') {
 2544:         my $count = keys(%{$users}); 
 2545:         my $requested = &freeze_escape($users);
 2546:         my $homeserver = &domain($udom,'primary');
 2547:         if ($homeserver ne '') {
 2548:             my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver);
 2549:             my $host=&hostname($homeserver);
 2550:             if ($queryid !~/^\Q$host\E\_/) {
 2551:                 &logthis('get_multiple_instusers invalid queryid: '.$queryid.
 2552:                          ' for host: '.$homeserver.'in domain '.$udom);
 2553:                 return ($outcome,$results);
 2554:             }
 2555:             my $response = &get_query_reply($queryid);
 2556:             my $maxtries = 5;
 2557:             if ($count > 100) {
 2558:                 $maxtries = 1+int($count/20);
 2559:             }
 2560:             my $tries = 1;
 2561:             while (($response=~/^timeout/) && ($tries <= $maxtries)) {
 2562:                 $response = &get_query_reply($queryid);
 2563:                 $tries ++;
 2564:             }
 2565:             if ($response eq '') {
 2566:                 $results = {};
 2567:                 foreach my $key (keys(%{$users})) {
 2568:                     my ($uname,$id);
 2569:                     if ($caller eq 'id') {
 2570:                         $id = $key;
 2571:                     } else {
 2572:                         $uname = $key;
 2573:                     }
 2574:                     my ($resp,%info) = &get_instuser($udom,$uname,$id);
 2575:                     $outcome = $resp;
 2576:                     if ($resp eq 'ok') {
 2577:                         %{$results} = (%{$results}, %info);
 2578:                     } else {
 2579:                         last;
 2580:                     }
 2581:                 }
 2582:             } elsif(!&error($response) && ($response ne 'refused')) {
 2583:                 if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) {
 2584:                     $outcome = $response;
 2585:                 } else {
 2586:                     ($outcome,my $userdata) = split(/=/,$response,2);
 2587:                     if ($outcome eq 'ok') {
 2588:                         $results = &thaw_unescape($userdata); 
 2589:                     }
 2590:                 }
 2591:             }
 2592:         }
 2593:     }
 2594:     return ($outcome,$results);
 2595: }
 2596: 
 2597: sub inst_rulecheck {
 2598:     my ($udom,$uname,$id,$item,$rules) = @_;
 2599:     my %returnhash;
 2600:     if ($udom ne '') {
 2601:         if (ref($rules) eq 'ARRAY') {
 2602:             @{$rules} = map {&escape($_);} (@{$rules});
 2603:             my $rulestr = join(':',@{$rules});
 2604:             my $homeserver=&domain($udom,'primary');
 2605:             if (($homeserver ne '') && ($homeserver ne 'no_host')) {
 2606:                 my $response;
 2607:                 if ($item eq 'username') {                
 2608:                     $response=&unescape(&reply('instrulecheck:'.&escape($udom).
 2609:                                               ':'.&escape($uname).':'.$rulestr,
 2610:                                               $homeserver));
 2611:                 } elsif ($item eq 'id') {
 2612:                     $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
 2613:                                               ':'.&escape($id).':'.$rulestr,
 2614:                                               $homeserver));
 2615:                 } elsif ($item eq 'selfcreate') {
 2616:                     $response=&unescape(&reply('instselfcreatecheck:'.
 2617:                                                &escape($udom).':'.&escape($uname).
 2618:                                               ':'.$rulestr,$homeserver));
 2619:                 } elsif ($item eq 'unamemap') {
 2620:                     $response=&unescape(&reply('instunamemapcheck:'.
 2621:                                                &escape($udom).':'.&escape($uname).
 2622:                                               ':'.$rulestr,$homeserver));
 2623:                 }
 2624:                 if ($response ne 'refused') {
 2625:                     my @pairs=split(/\&/,$response);
 2626:                     foreach my $item (@pairs) {
 2627:                         my ($key,$value)=split(/=/,$item,2);
 2628:                         $key = &unescape($key);
 2629:                         next if ($key =~ /^error: 2 /);
 2630:                         $returnhash{$key}=&thaw_unescape($value);
 2631:                     }
 2632:                 }
 2633:             }
 2634:         }
 2635:     }
 2636:     return %returnhash;
 2637: }
 2638: 
 2639: sub inst_userrules {
 2640:     my ($udom,$check) = @_;
 2641:     my (%ruleshash,@ruleorder);
 2642:     if ($udom ne '') {
 2643:         my $homeserver=&domain($udom,'primary');
 2644:         if (($homeserver ne '') && ($homeserver ne 'no_host')) {
 2645:             my $response;
 2646:             if ($check eq 'id') {
 2647:                 $response=&reply('instidrules:'.&escape($udom),
 2648:                                  $homeserver);
 2649:             } elsif ($check eq 'email') {
 2650:                 $response=&reply('instemailrules:'.&escape($udom),
 2651:                                  $homeserver);
 2652:             } elsif ($check eq 'unamemap') {
 2653:                 $response=&reply('unamemaprules:'.&escape($udom),
 2654:                                  $homeserver); 
 2655:             } else {
 2656:                 $response=&reply('instuserrules:'.&escape($udom),
 2657:                                  $homeserver);
 2658:             }
 2659:             if (($response ne 'refused') && ($response ne 'error') && 
 2660:                 ($response ne 'unknown_cmd') && 
 2661:                 ($response ne 'no_such_host')) {
 2662:                 my ($hashitems,$orderitems) = split(/:/,$response);
 2663:                 my @pairs=split(/\&/,$hashitems);
 2664:                 foreach my $item (@pairs) {
 2665:                     my ($key,$value)=split(/=/,$item,2);
 2666:                     $key = &unescape($key);
 2667:                     next if ($key =~ /^error: 2 /);
 2668:                     $ruleshash{$key}=&thaw_unescape($value);
 2669:                 }
 2670:                 my @esc_order = split(/\&/,$orderitems);
 2671:                 foreach my $item (@esc_order) {
 2672:                     push(@ruleorder,&unescape($item));
 2673:                 }
 2674:             }
 2675:         }
 2676:     }
 2677:     return (\%ruleshash,\@ruleorder);
 2678: }
 2679: 
 2680: # ------------- Get Authentication, Language and User Tools Defaults for Domain
 2681: 
 2682: sub get_domain_defaults {
 2683:     my ($domain,$ignore_cache) = @_;
 2684:     return if (($domain eq '') || ($domain eq 'public'));
 2685:     my $cachetime = 60*60*24;
 2686:     unless ($ignore_cache) {
 2687:         my ($result,$cached)=&is_cached_new('domdefaults',$domain);
 2688:         if (defined($cached)) {
 2689:             if (ref($result) eq 'HASH') {
 2690:                 return %{$result};
 2691:             }
 2692:         }
 2693:     }
 2694:     my %domdefaults;
 2695:     my %domconfig =
 2696:          &get_dom('configuration',['defaults','quotas',
 2697:                                   'requestcourses','inststatus',
 2698:                                   'coursedefaults','usersessions',
 2699:                                   'requestauthor','selfenrollment',
 2700:                                   'coursecategories','ssl','autoenroll',
 2701:                                   'trust','helpsettings','wafproxy',
 2702:                                   'ltisec','toolsec'],$domain);
 2703:     my @coursetypes = ('official','unofficial','community','textbook','placement');
 2704:     if (ref($domconfig{'defaults'}) eq 'HASH') {
 2705:         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
 2706:         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
 2707:         $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
 2708:         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
 2709:         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
 2710:         $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
 2711:         $domdefaults{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'};
 2712:         $domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'};
 2713:         $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
 2714:         $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
 2715:         $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
 2716:         $domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
 2717:     } else {
 2718:         $domdefaults{'lang_def'} = &domain($domain,'lang_def');
 2719:         $domdefaults{'auth_def'} = &domain($domain,'auth_def');
 2720:         $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
 2721:     }
 2722:     if (ref($domconfig{'quotas'}) eq 'HASH') {
 2723:         if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
 2724:             $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
 2725:         } else {
 2726:             $domdefaults{'defaultquota'} = $domconfig{'quotas'};
 2727:         }
 2728:         my @usertools = ('aboutme','blog','webdav','portfolio');
 2729:         foreach my $item (@usertools) {
 2730:             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
 2731:                 $domdefaults{$item} = $domconfig{'quotas'}{$item};
 2732:             }
 2733:         }
 2734:         if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') {
 2735:             $domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'};
 2736:         }
 2737:     }
 2738:     if (ref($domconfig{'requestcourses'}) eq 'HASH') {
 2739:         foreach my $item ('official','unofficial','community','textbook','placement') {
 2740:             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
 2741:         }
 2742:     }
 2743:     if (ref($domconfig{'requestauthor'}) eq 'HASH') {
 2744:         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
 2745:     }
 2746:     if (ref($domconfig{'inststatus'}) eq 'HASH') {
 2747:         foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
 2748:             $domdefaults{$item} = $domconfig{'inststatus'}{$item};
 2749:         }
 2750:     }
 2751:     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
 2752:         $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
 2753:         $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
 2754:         $domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
 2755:         $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
 2756:         if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
 2757:             $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
 2758:         }
 2759:         foreach my $type (@coursetypes) {
 2760:             if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
 2761:                 unless ($type eq 'community') {
 2762:                     $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};
 2763:                 }
 2764:             }
 2765:             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
 2766:                 $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
 2767:             }
 2768:             if ($domdefaults{'postsubmit'} eq 'on') {
 2769:                 if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
 2770:                     $domdefaults{$type.'postsubtimeout'} = 
 2771:                         $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; 
 2772:                 }
 2773:             }
 2774:         }
 2775:         if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
 2776:             if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
 2777:                 my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}};
 2778:                 if (@clonecodes) {
 2779:                     $domdefaults{'canclone'} = join('+',@clonecodes);
 2780:                 }
 2781:             }
 2782:         } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
 2783:             $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
 2784:         }
 2785:         if ($domconfig{'coursedefaults'}{'texengine'}) {
 2786:             $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
 2787:         }
 2788:         if (exists($domconfig{'coursedefaults'}{'ltiauth'})) {
 2789:             $domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'};
 2790:         }
 2791:     }
 2792:     if (ref($domconfig{'usersessions'}) eq 'HASH') {
 2793:         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
 2794:             $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'};
 2795:         }
 2796:         if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
 2797:             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
 2798:         }
 2799:         if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
 2800:             $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
 2801:         }
 2802:         if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
 2803:             $domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
 2804:         }
 2805:     }
 2806:     if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
 2807:         if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
 2808:             my @settings = ('types','registered','enroll_dates','access_dates','section',
 2809:                             'approval','limit');
 2810:             foreach my $type (@coursetypes) {
 2811:                 if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') {
 2812:                     my @mgrdc = ();
 2813:                     foreach my $item (@settings) {
 2814:                         if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') {
 2815:                             push(@mgrdc,$item);
 2816:                         }
 2817:                     }
 2818:                     if (@mgrdc) {
 2819:                         $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc);
 2820:                     }
 2821:                 }
 2822:             }
 2823:         }
 2824:         if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') {
 2825:             foreach my $type (@coursetypes) {
 2826:                 if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') {
 2827:                     foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) {
 2828:                         $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item};
 2829:                     }
 2830:                 }
 2831:             }
 2832:         }
 2833:     }
 2834:     if (ref($domconfig{'coursecategories'}) eq 'HASH') {
 2835:         $domdefaults{'catauth'} = 'std';
 2836:         $domdefaults{'catunauth'} = 'std';
 2837:         if ($domconfig{'coursecategories'}{'auth'}) {
 2838:             $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
 2839:         }
 2840:         if ($domconfig{'coursecategories'}{'unauth'}) {
 2841:             $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
 2842:         }
 2843:     }
 2844:     if (ref($domconfig{'ssl'}) eq 'HASH') {
 2845:         if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {
 2846:             $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};
 2847:         }
 2848:         if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') {
 2849:             $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'};
 2850:         }
 2851:         if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') {
 2852:             $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'};
 2853:         }
 2854:     }
 2855:     if (ref($domconfig{'trust'}) eq 'HASH') {
 2856:         my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg);
 2857:         foreach my $prefix (@prefixes) {
 2858:             if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') {
 2859:                 $domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix};
 2860:             }
 2861:         }
 2862:     }
 2863:     if (ref($domconfig{'autoenroll'}) eq 'HASH') {
 2864:         $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
 2865:         $domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
 2866:     }
 2867:     if (ref($domconfig{'helpsettings'}) eq 'HASH') {
 2868:         $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
 2869:         if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
 2870:             $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
 2871:         }
 2872:     }
 2873:     if (ref($domconfig{'wafproxy'}) eq 'HASH') {
 2874:         foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
 2875:             if ($domconfig{'wafproxy'}{$item}) {
 2876:                 $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
 2877:             }
 2878:         }
 2879:     }
 2880:     if (ref($domconfig{'ltisec'}) eq 'HASH') {
 2881:         if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') {
 2882:             $domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'};
 2883:             $domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'};
 2884:             $domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'};
 2885:         }
 2886:         if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
 2887:             if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
 2888:                 $domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
 2889:             }
 2890:         }
 2891:     }
 2892:     if (ref($domconfig{'toolsec'}) eq 'HASH') {
 2893:         if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
 2894:             $domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'};
 2895:             $domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'};
 2896:         }
 2897:         if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') {
 2898:             if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') {
 2899:                 $domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'};
 2900:             }
 2901:         }
 2902:     }
 2903:     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
 2904:     return %domdefaults;
 2905: }
 2906: 
 2907: sub get_dom_cats {
 2908:     my ($dom) = @_;
 2909:     return unless (&domain($dom));
 2910:     my ($cats,$cached)=&is_cached_new('cats',$dom);
 2911:     unless (defined($cached)) {
 2912:         my %domconfig = &get_dom('configuration',['coursecategories'],$dom);
 2913:         if (ref($domconfig{'coursecategories'}) eq 'HASH') {
 2914:             if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') {
 2915:                 %{$cats} = %{$domconfig{'coursecategories'}{'cats'}};
 2916:             } else {
 2917:                 $cats = {};
 2918:             }
 2919:         } else {
 2920:             $cats = {};
 2921:         }
 2922:         &do_cache_new('cats',$dom,$cats,3600);
 2923:     }
 2924:     return $cats;
 2925: }
 2926: 
 2927: sub get_dom_instcats {
 2928:     my ($dom) = @_;
 2929:     return unless (&domain($dom));
 2930:     my ($instcats,$cached)=&is_cached_new('instcats',$dom);
 2931:     unless (defined($cached)) {
 2932:         my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order);
 2933:         my $totcodes = &retrieve_instcodes(\%coursecodes,$dom);
 2934:         if ($totcodes > 0) {
 2935:             my $caller = 'global';
 2936:             if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
 2937:                                       \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
 2938:                 $instcats = {
 2939:                                 totcodes => $totcodes,
 2940:                                 codes => \%codes,
 2941:                                 codetitles => \@codetitles,
 2942:                                 cat_titles => \%cat_titles,
 2943:                                 cat_order => \%cat_order,
 2944:                             };
 2945:                 &do_cache_new('instcats',$dom,$instcats,3600);
 2946:             }
 2947:         }
 2948:     }
 2949:     return $instcats;
 2950: }
 2951: 
 2952: sub retrieve_instcodes {
 2953:     my ($coursecodes,$dom) = @_;
 2954:     my $totcodes;
 2955:     my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course');
 2956:     foreach my $course (keys(%courses)) {
 2957:         if (ref($courses{$course}) eq 'HASH') {
 2958:             if ($courses{$course}{'inst_code'} ne '') {
 2959:                 $$coursecodes{$course} = $courses{$course}{'inst_code'};
 2960:                 $totcodes ++;
 2961:             }
 2962:         }
 2963:     }
 2964:     return $totcodes;
 2965: }
 2966: 
 2967: sub course_portal_url {
 2968:     my ($cnum,$cdom,$r) = @_;
 2969:     my $chome = &homeserver($cnum,$cdom);
 2970:     my $hostname = &hostname($chome);
 2971:     my $protocol = $protocol{$chome};
 2972:     $protocol = 'http' if ($protocol ne 'https');
 2973:     my %domdefaults = &get_domain_defaults($cdom);
 2974:     my $firsturl;
 2975:     if ($domdefaults{'portal_def'}) {
 2976:         $firsturl = $domdefaults{'portal_def'};
 2977:     } else {
 2978:         my $alias = &use_proxy_alias($r,$chome);
 2979:         $hostname = $alias if ($alias ne '');
 2980:         $firsturl = $protocol.'://'.$hostname;
 2981:     }
 2982:     return $firsturl;
 2983: }
 2984: 
 2985: sub url_prefix {
 2986:     my ($r,$dom,$home,$context) = @_;
 2987:     my $prefix;
 2988:     my %domdefs = &get_domain_defaults($dom);
 2989:     if ($domdefs{'portal_def'} && $domdefs{'portal_def_'.$context}) {
 2990:         if ($domdefs{'portal_def'} =~ m{^(https?://[^/]+)}) {
 2991:             $prefix = $1;
 2992:         }
 2993:     }
 2994:     if ($prefix eq '') {
 2995:         my $hostname = &hostname($home);
 2996:         my $protocol = $protocol{$home};
 2997:         $protocol = 'http' if ($protocol{$home} ne 'https');
 2998:         my $alias = &use_proxy_alias($r,$home);
 2999:         $hostname = $alias if ($alias ne '');
 3000:         $prefix = $protocol.'://'.$hostname;
 3001:     }
 3002:     return $prefix;
 3003: }
 3004: 
 3005: # --------------------------------------------- Get domain config for passwords
 3006: 
 3007: sub get_passwdconf {
 3008:     my ($dom) = @_;
 3009:     my (%passwdconf,$gotconf,$lookup);
 3010:     my ($result,$cached)=&is_cached_new('passwdconf',$dom);
 3011:     if (defined($cached)) {
 3012:         if (ref($result) eq 'HASH') {
 3013:             %passwdconf = %{$result};
 3014:             $gotconf = 1;
 3015:         }
 3016:     }
 3017:     unless ($gotconf) {
 3018:         my %domconfig = &get_dom('configuration',['passwords'],$dom);
 3019:         if (ref($domconfig{'passwords'}) eq 'HASH') {
 3020:             %passwdconf = %{$domconfig{'passwords'}};
 3021:         }
 3022:         my $cachetime = 24*60*60;
 3023:         &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
 3024:     }
 3025:     return %passwdconf;
 3026: }
 3027: 
 3028: # --------------------------------------------------- Assign a key to a student
 3029: 
 3030: sub assign_access_key {
 3031: #
 3032: # a valid key looks like uname:udom#comments
 3033: # comments are being appended
 3034: #
 3035:     my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
 3036:     $kdom=
 3037:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom));
 3038:     $knum=
 3039:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum));
 3040:     $cdom=
 3041:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
 3042:     $cnum=
 3043:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
 3044:     $udom=$env{'user.name'} unless (defined($udom));
 3045:     $uname=$env{'user.domain'} unless (defined($uname));
 3046:     my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
 3047:     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
 3048:         ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
 3049:                                                   # assigned to this person
 3050:                                                   # - this should not happen,
 3051:                                                   # unless something went wrong
 3052:                                                   # the first time around
 3053: # ready to assign
 3054:         $logentry=$1.'; '.$logentry;
 3055:         if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
 3056:                                                  $kdom,$knum) eq 'ok') {
 3057: # key now belongs to user
 3058: 	    my $envkey='key.'.$cdom.'_'.$cnum;
 3059:             if (&put('environment',{$envkey => $ckey}) eq 'ok') {
 3060:                 &appenv({'environment.'.$envkey => $ckey});
 3061:                 return 'ok';
 3062:             } else {
 3063:                 return 
 3064:   'error: Count not permanently assign key, will need to be re-entered later.';
 3065: 	    }
 3066:         } else {
 3067:             return 'error: Could not assign key, try again later.';
 3068:         }
 3069:     } elsif (!$existing{$ckey}) {
 3070: # the key does not exist
 3071: 	return 'error: The key does not exist';
 3072:     } else {
 3073: # the key is somebody else's
 3074: 	return 'error: The key is already in use';
 3075:     }
 3076: }
 3077: 
 3078: # ------------------------------------------ put an additional comment on a key
 3079: 
 3080: sub comment_access_key {
 3081: #
 3082: # a valid key looks like uname:udom#comments
 3083: # comments are being appended
 3084: #
 3085:     my ($ckey,$cdom,$cnum,$logentry)=@_;
 3086:     $cdom=
 3087:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
 3088:     $cnum=
 3089:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
 3090:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
 3091:     if ($existing{$ckey}) {
 3092:         $existing{$ckey}.='; '.$logentry;
 3093: # ready to assign
 3094:         if (&put('accesskeys',{$ckey=>$existing{$ckey}},
 3095:                                                  $cdom,$cnum) eq 'ok') {
 3096: 	    return 'ok';
 3097:         } else {
 3098: 	    return 'error: Count not store comment.';
 3099:         }
 3100:     } else {
 3101: # the key does not exist
 3102: 	return 'error: The key does not exist';
 3103:     }
 3104: }
 3105: 
 3106: # ------------------------------------------------------ Generate a set of keys
 3107: 
 3108: sub generate_access_keys {
 3109:     my ($number,$cdom,$cnum,$logentry)=@_;
 3110:     $cdom=
 3111:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
 3112:     $cnum=
 3113:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
 3114:     unless (&allowed('mky',$cdom)) { return 0; }
 3115:     unless (($cdom) && ($cnum)) { return 0; }
 3116:     if ($number>10000) { return 0; }
 3117:     sleep(2); # make sure don't get same seed twice
 3118:     srand(time()^($$+($$<<15))); # from "Programming Perl"
 3119:     my $total=0;
 3120:     for (my $i=1;$i<=$number;$i++) {
 3121:        my $newkey=sprintf("%lx",int(100000*rand)).'-'.
 3122:                   sprintf("%lx",int(100000*rand)).'-'.
 3123:                   sprintf("%lx",int(100000*rand));
 3124:        $newkey=~s/1/g/g; # folks mix up 1 and l
 3125:        $newkey=~s/0/h/g; # and also 0 and O
 3126:        my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
 3127:        if ($existing{$newkey}) {
 3128:            $i--;
 3129:        } else {
 3130: 	  if (&put('accesskeys',
 3131:               { $newkey => '# generated '.localtime().
 3132:                            ' by '.$env{'user.name'}.'@'.$env{'user.domain'}.
 3133:                            '; '.$logentry },
 3134: 		   $cdom,$cnum) eq 'ok') {
 3135:               $total++;
 3136: 	  }
 3137:        }
 3138:     }
 3139:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
 3140:          'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
 3141:     return $total;
 3142: }
 3143: 
 3144: # ------------------------------------------------------- Validate an accesskey
 3145: 
 3146: sub validate_access_key {
 3147:     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
 3148:     $cdom=
 3149:    $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
 3150:     $cnum=
 3151:    $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
 3152:     $udom=$env{'user.domain'} unless (defined($udom));
 3153:     $uname=$env{'user.name'} unless (defined($uname));
 3154:     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
 3155:     return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
 3156: }
 3157: 
 3158: # ------------------------------------- Find the section of student in a course
 3159: sub devalidate_getsection_cache {
 3160:     my ($udom,$unam,$courseid)=@_;
 3161:     my $hashid="$udom:$unam:$courseid";
 3162:     &devalidate_cache_new('getsection',$hashid);
 3163: }
 3164: 
 3165: sub courseid_to_courseurl {
 3166:     my ($courseid) = @_;
 3167:     #already url style courseid
 3168:     return $courseid if ($courseid =~ m{^/});
 3169: 
 3170:     if (exists($env{'course.'.$courseid.'.num'})) {
 3171: 	my $cnum = $env{'course.'.$courseid.'.num'};
 3172: 	my $cdom = $env{'course.'.$courseid.'.domain'};
 3173: 	return "/$cdom/$cnum";
 3174:     }
 3175: 
 3176:     my %courseinfo=&coursedescription($courseid);
 3177:     if (exists($courseinfo{'num'})) {
 3178: 	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
 3179:     }
 3180: 
 3181:     return undef;
 3182: }
 3183: 
 3184: sub getsection {
 3185:     my ($udom,$unam,$courseid)=@_;
 3186:     my $cachetime=1800;
 3187: 
 3188:     my $hashid="$udom:$unam:$courseid";
 3189:     my ($result,$cached)=&is_cached_new('getsection',$hashid);
 3190:     if (defined($cached)) { return $result; }
 3191: 
 3192:     my %Pending; 
 3193:     my %Expired;
 3194:     #
 3195:     # Each role can either have not started yet (pending), be active, 
 3196:     #    or have expired.
 3197:     #
 3198:     # If there is an active role, we are done.
 3199:     #
 3200:     # If there is more than one role which has not started yet, 
 3201:     #     choose the one which will start sooner
 3202:     # If there is one role which has not started yet, return it.
 3203:     #
 3204:     # If there is more than one expired role, choose the one which ended last.
 3205:     # If there is a role which has expired, return it.
 3206:     #
 3207:     $courseid = &courseid_to_courseurl($courseid);
 3208:     my %roleshash = &dump('roles',$udom,$unam,$courseid);
 3209:     foreach my $key (keys(%roleshash)) {
 3210:         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
 3211:         my $section=$1;
 3212:         if ($key eq $courseid.'_st') { $section=''; }
 3213:         my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
 3214:         my $now=time;
 3215:         if (defined($end) && $end && ($now > $end)) {
 3216:             $Expired{$end}=$section;
 3217:             next;
 3218:         }
 3219:         if (defined($start) && $start && ($now < $start)) {
 3220:             $Pending{$start}=$section;
 3221:             next;
 3222:         }
 3223:         return &do_cache_new('getsection',$hashid,$section,$cachetime);
 3224:     }
 3225:     #
 3226:     # Presumedly there will be few matching roles from the above
 3227:     # loop and the sorting time will be negligible.
 3228:     if (scalar(keys(%Pending))) {
 3229:         my ($time) = sort {$a <=> $b} keys(%Pending);
 3230:         return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
 3231:     } 
 3232:     if (scalar(keys(%Expired))) {
 3233:         my @sorted = sort {$a <=> $b} keys(%Expired);
 3234:         my $time = pop(@sorted);
 3235:         return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
 3236:     }
 3237:     return &do_cache_new('getsection',$hashid,'-1',$cachetime);
 3238: }
 3239: 
 3240: sub save_cache {
 3241:     &purge_remembered();
 3242:     #&Apache::loncommon::validate_page();
 3243:     undef(%env);
 3244:     undef($env_loaded);
 3245: }
 3246: 
 3247: my $to_remember=-1;
 3248: my %remembered;
 3249: my %accessed;
 3250: my $kicks=0;
 3251: my $hits=0;
 3252: sub make_key {
 3253:     my ($name,$id) = @_;
 3254:     if (length($id) > 65 
 3255: 	&& length(&escape($id)) > 200) {
 3256: 	$id=length($id).':'.&Digest::MD5::md5_hex($id);
 3257:     }
 3258:     return &escape($name.':'.$id);
 3259: }
 3260: 
 3261: sub devalidate_cache_new {
 3262:     my ($name,$id,$debug) = @_;
 3263:     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
 3264:     my $remembered_id=$name.':'.$id;
 3265:     $id=&make_key($name,$id);
 3266:     $memcache->delete($id);
 3267:     delete($remembered{$remembered_id});
 3268:     delete($accessed{$remembered_id});
 3269: }
 3270: 
 3271: sub is_cached_new {
 3272:     my ($name,$id,$debug) = @_;
 3273:     my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible
 3274:     if (exists($remembered{$remembered_id})) {
 3275: 	if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
 3276: 	$accessed{$remembered_id}=[&gettimeofday()];
 3277: 	$hits++;
 3278: 	return ($remembered{$remembered_id},1);
 3279:     }
 3280:     $id=&make_key($name,$id);
 3281:     my $value = $memcache->get($id);
 3282:     if (!(defined($value))) {
 3283: 	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
 3284: 	return (undef,undef);
 3285:     }
 3286:     if ($value eq '__undef__') {
 3287: 	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
 3288: 	$value=undef;
 3289:     }
 3290:     &make_room($remembered_id,$value,$debug);
 3291:     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
 3292:     return ($value,1);
 3293: }
 3294: 
 3295: sub do_cache_new {
 3296:     my ($name,$id,$value,$time,$debug) = @_;
 3297:     my $remembered_id=$name.':'.$id;
 3298:     $id=&make_key($name,$id);
 3299:     my $setvalue=$value;
 3300:     if (!defined($setvalue)) {
 3301: 	$setvalue='__undef__';
 3302:     }
 3303:     if (!defined($time) ) {
 3304: 	$time=600;
 3305:     }
 3306:     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
 3307:     my $result = $memcache->set($id,$setvalue,$time);
 3308:     if (! $result) {
 3309: 	&logthis("caching of id -> $id  failed");
 3310: 	$memcache->disconnect_all();
 3311:     }
 3312:     # need to make a copy of $value
 3313:     &make_room($remembered_id,$value,$debug);
 3314:     return $value;
 3315: }
 3316: 
 3317: sub make_room {
 3318:     my ($remembered_id,$value,$debug)=@_;
 3319: 
 3320:     $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value)
 3321:                                     : $value;
 3322:     if ($to_remember<0) { return; }
 3323:     $accessed{$remembered_id}=[&gettimeofday()];
 3324:     if (scalar(keys(%remembered)) <= $to_remember) { return; }
 3325:     my $to_kick;
 3326:     my $max_time=0;
 3327:     foreach my $other (keys(%accessed)) {
 3328: 	if (&tv_interval($accessed{$other}) > $max_time) {
 3329: 	    $to_kick=$other;
 3330: 	    $max_time=&tv_interval($accessed{$other});
 3331: 	}
 3332:     }
 3333:     delete($remembered{$to_kick});
 3334:     delete($accessed{$to_kick});
 3335:     $kicks++;
 3336:     if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
 3337:     return;
 3338: }
 3339: 
 3340: sub purge_remembered {
 3341:     #&logthis("Tossing ".scalar(keys(%remembered)));
 3342:     #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
 3343:     undef(%remembered);
 3344:     undef(%accessed);
 3345: }
 3346: # ------------------------------------- Read an entry from a user's environment
 3347: 
 3348: sub userenvironment {
 3349:     my ($udom,$unam,@what)=@_;
 3350:     my $items;
 3351:     foreach my $item (@what) {
 3352:         $items.=&escape($item).'&';
 3353:     }
 3354:     $items=~s/\&$//;
 3355:     my %returnhash=();
 3356:     my $uhome = &homeserver($unam,$udom);
 3357:     unless ($uhome eq 'no_host') {
 3358:         my @answer=split(/\&/, 
 3359:             &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
 3360:         if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) {
 3361:             return %returnhash;
 3362:         }
 3363:         my $i;
 3364:         for ($i=0;$i<=$#what;$i++) {
 3365: 	    $returnhash{$what[$i]}=&unescape($answer[$i]);
 3366:         }
 3367:     }
 3368:     return %returnhash;
 3369: }
 3370: 
 3371: # ---------------------------------------------------------- Get a studentphoto
 3372: sub studentphoto {
 3373:     my ($udom,$unam,$ext) = @_;
 3374:     my $home=&homeserver($unam,$udom);
 3375:     if (defined($env{'request.course.id'})) {
 3376:         if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
 3377:             if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
 3378:                 return(&retrievestudentphoto($udom,$unam,$ext)); 
 3379:             } else {
 3380:                 my ($result,$perm_reqd)=
 3381: 		    &auto_photo_permission($unam,$udom);
 3382:                 if ($result eq 'ok') {
 3383:                     if (!($perm_reqd eq 'yes')) {
 3384:                         return(&retrievestudentphoto($udom,$unam,$ext));
 3385:                     }
 3386:                 }
 3387:             }
 3388:         }
 3389:     } else {
 3390:         my ($result,$perm_reqd) = 
 3391: 	    &auto_photo_permission($unam,$udom);
 3392:         if ($result eq 'ok') {
 3393:             if (!($perm_reqd eq 'yes')) {
 3394:                 return(&retrievestudentphoto($udom,$unam,$ext));
 3395:             }
 3396:         }
 3397:     }
 3398:     return '/adm/lonKaputt/lonlogo_broken.gif';
 3399: }
 3400: 
 3401: sub retrievestudentphoto {
 3402:     my ($udom,$unam,$ext,$type) = @_;
 3403:     my $home=&homeserver($unam,$udom);
 3404:     my $ret=&reply("studentphoto:$udom:$unam:$ext:$type",$home);
 3405:     if ($ret eq 'ok') {
 3406:         my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
 3407:         if ($type eq 'thumbnail') {
 3408:             $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
 3409:         }
 3410:         my $tokenurl=&tokenwrapper($url);
 3411:         return $tokenurl;
 3412:     } else {
 3413:         if ($type eq 'thumbnail') {
 3414:             return '/adm/lonKaputt/genericstudent_tn.gif';
 3415:         } else { 
 3416:             return '/adm/lonKaputt/lonlogo_broken.gif';
 3417:         }
 3418:     }
 3419: }
 3420: 
 3421: # -------------------------------------------------------------------- New chat
 3422: 
 3423: sub chatsend {
 3424:     my ($newentry,$anon,$group)=@_;
 3425:     my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
 3426:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 3427:     my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
 3428:     &reply('chatsend:'.$cdom.':'.$cnum.':'.
 3429: 	   &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
 3430: 		   &escape($newentry)).':'.$group,$chome);
 3431: }
 3432: 
 3433: # ------------------------------------------ Find current version of a resource
 3434: 
 3435: sub getversion {
 3436:     my $fname=&clutter(shift);
 3437:     unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }
 3438:     return &currentversion(&filelocation('',$fname));
 3439: }
 3440: 
 3441: sub currentversion {
 3442:     my $fname=shift;
 3443:     my $author=$fname;
 3444:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 3445:     my ($udom,$uname)=split(/\//,$author);
 3446:     my $home=&homeserver($uname,$udom);
 3447:     if ($home eq 'no_host') { 
 3448:         return -1; 
 3449:     }
 3450:     my $answer=&reply("currentversion:$fname",$home);
 3451:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
 3452: 	return -1;
 3453:     }
 3454:     return $answer;
 3455: }
 3456: 
 3457: #
 3458: # Return special version number of resource if set by override, empty otherwise
 3459: #
 3460: sub usedversion {
 3461:     my $fname=shift;
 3462:     unless ($fname) { $fname=$env{'request.uri'}; }
 3463:     my ($urlversion)=($fname=~/\.(\d+)\.\w+$/);
 3464:     if ($urlversion) { return $urlversion; }
 3465:     return '';
 3466: }
 3467: 
 3468: # ----------------------------- Subscribe to a resource, return URL if possible
 3469: 
 3470: sub subscribe {
 3471:     my $fname=shift;
 3472:     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
 3473:     $fname=~s/[\n\r]//g;
 3474:     my $author=$fname;
 3475:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 3476:     my ($udom,$uname)=split(/\//,$author);
 3477:     my $home=homeserver($uname,$udom);
 3478:     if ($home eq 'no_host') {
 3479:         return 'not_found';
 3480:     }
 3481:     my $answer=reply("sub:$fname",$home);
 3482:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
 3483: 	$answer.=' by '.$home;
 3484:     }
 3485:     return $answer;
 3486: }
 3487:     
 3488: # -------------------------------------------------------------- Replicate file
 3489: 
 3490: sub repcopy {
 3491:     my $filename=shift;
 3492:     $filename=~s/\/+/\//g;
 3493:     my $londocroot = $perlvar{'lonDocRoot'};
 3494:     if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
 3495:     if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
 3496:     if ($filename=~m{^\Q$londocroot/userfiles/\E} or
 3497: 	$filename=~m{^/*(uploaded|editupload)/}) {
 3498: 	return &repcopy_userfile($filename);
 3499:     }
 3500:     $filename=~s/[\n\r]//g;
 3501:     my $transname="$filename.in.transfer";
 3502: # FIXME: this should flock
 3503:     if ((-e $filename) || (-e $transname)) { return 'ok'; }
 3504:     my $remoteurl=subscribe($filename);
 3505:     if ($remoteurl =~ /^con_lost by/) {
 3506: 	   &logthis("Subscribe returned $remoteurl: $filename");
 3507:            return 'unavailable';
 3508:     } elsif ($remoteurl eq 'not_found') {
 3509: 	   #&logthis("Subscribe returned not_found: $filename");
 3510: 	   return 'not_found';
 3511:     } elsif ($remoteurl =~ /^rejected by/) {
 3512: 	   &logthis("Subscribe returned $remoteurl: $filename");
 3513:            return 'forbidden';
 3514:     } elsif ($remoteurl eq 'directory') {
 3515:            return 'ok';
 3516:     } else {
 3517:         my $author=$filename;
 3518:         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 3519:         my ($udom,$uname)=split(/\//,$author);
 3520:         my $home=homeserver($uname,$udom);
 3521:         unless ($home eq $perlvar{'lonHostID'}) {
 3522:            my @parts=split(/\//,$filename);
 3523:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
 3524:            if ($path ne "$londocroot/res") {
 3525:                &logthis("Malconfiguration for replication: $filename");
 3526: 	       return 'bad_request';
 3527:            }
 3528:            my $count;
 3529:            for ($count=5;$count<$#parts;$count++) {
 3530:                $path.="/$parts[$count]";
 3531:                if ((-e $path)!=1) {
 3532: 		   mkdir($path,0777);
 3533:                }
 3534:            }
 3535:            my $request=new HTTP::Request('GET',"$remoteurl");
 3536:            my $response;
 3537:            if ($remoteurl =~ m{/raw/}) {
 3538:                $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1);
 3539:            } else {
 3540:                $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1);
 3541:            }
 3542:            if ($response->is_error()) {
 3543: 	       unlink($transname);
 3544:                my $message=$response->status_line;
 3545:                &logthis("<font color=\"blue\">WARNING:"
 3546:                        ." LWP get: $message: $filename</font>");
 3547:                return 'unavailable';
 3548:            } else {
 3549: 	       if ($remoteurl!~/\.meta$/) {
 3550:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
 3551:                   my $mresponse;
 3552:                   if ($remoteurl =~ m{/raw/}) {
 3553:                       $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1);
 3554:                   } else {
 3555:                       $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1);
 3556:                   }
 3557:                   if ($mresponse->is_error()) {
 3558: 		      unlink($filename.'.meta');
 3559:                       &logthis(
 3560:                      "<font color=\"yellow\">INFO: No metadata: $filename</font>");
 3561:                   }
 3562: 	       }
 3563:                rename($transname,$filename);
 3564:                return 'ok';
 3565:            }
 3566:        }
 3567:     }
 3568: }
 3569: 
 3570: # ------------------------------------------------- Unsubscribe from a resource
 3571: 
 3572: sub unsubscribe {
 3573:     my ($fname) = @_;
 3574:     my $answer;
 3575:     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
 3576:     $fname=~s/[\n\r]//g;
 3577:     my $author=$fname;
 3578:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
 3579:     my ($udom,$uname)=split(/\//,$author);
 3580:     my $home=homeserver($uname,$udom);
 3581:     if ($home eq 'no_host') {
 3582:         $answer = 'no_host';
 3583:     } elsif (grep { $_ eq $home } &current_machine_ids()) {
 3584:         $answer = 'home';
 3585:     } else {
 3586:         my $defdom = $perlvar{'lonDefDomain'};
 3587:         if (&will_trust('content',$defdom,$udom)) {
 3588:             $answer = reply("unsub:$fname",$home);
 3589:         } else {
 3590:             $answer = 'untrusted';
 3591:         }
 3592:     }
 3593:     return $answer;
 3594: }
 3595: 
 3596: # ------------------------------------------------ Get server side include body
 3597: sub ssi_body {
 3598:     my ($filelink,%form)=@_;
 3599:     if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
 3600:         $form{'LONCAPA_INTERNAL_no_discussion'}='true';
 3601:     }
 3602:     my $output='';
 3603:     my $response;
 3604:     if ($filelink=~/^https?\:/) {
 3605:        ($output,$response)=&externalssi($filelink);
 3606:     } else {
 3607:        $filelink .= $filelink=~/\?/ ? '&' : '?';
 3608:        $filelink .= 'inhibitmenu=yes';
 3609:        ($output,$response)=&ssi($filelink,%form);
 3610:     }
 3611:     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
 3612:     $output=~s/^.*?\<body[^\>]*\>//si;
 3613:     $output=~s/\<\/body\s*\>.*?$//si;
 3614:     if (wantarray) {
 3615:         return ($output, $response);
 3616:     } else {
 3617:         return $output;
 3618:     }
 3619: }
 3620: 
 3621: # --------------------------------------------------------- Server Side Include
 3622: 
 3623: sub absolute_url {
 3624:     my ($host_name,$unalias,$keep_proto) = @_;
 3625:     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
 3626:     if ($host_name eq '') {
 3627: 	$host_name = $ENV{'SERVER_NAME'};
 3628:     }
 3629:     if ($unalias) {
 3630:         my $alias = &get_proxy_alias();
 3631:         if ($alias eq $host_name) {
 3632:             my $lonhost = $perlvar{'lonHostID'};
 3633:             my $hostname = &hostname($lonhost);
 3634:             my $lcproto; 
 3635:             if (($keep_proto) || ($hostname eq '')) {
 3636:                 $lcproto = $protocol;
 3637:             } else {
 3638:                 $lcproto = $protocol{$lonhost};
 3639:                 $lcproto = 'http' if ($lcproto ne 'https');
 3640:                 $lcproto .= '://';
 3641:             }
 3642:             unless ($hostname eq '') {
 3643:                 return $lcproto.$hostname;
 3644:             }
 3645:         }
 3646:     }
 3647:     return $protocol.$host_name;
 3648: }
 3649: 
 3650: #
 3651: #   Server side include.
 3652: # Parameters:
 3653: #  fn     Possibly encrypted resource name/id.
 3654: #  form   Hash that describes how the rendering should be done
 3655: #         and other things.
 3656: # Returns:
 3657: #   Scalar context: The content of the response.
 3658: #   Array context:  2 element list of the content and the full response object.
 3659: #     
 3660: sub ssi {
 3661: 
 3662:     my ($fn,%form)=@_;
 3663:     my ($host,$request,$response);
 3664:     $host = &absolute_url('',1);
 3665: 
 3666:     $form{'no_update_last_known'}=1;
 3667:     &Apache::lonenc::check_encrypt(\$fn);
 3668:     if (%form) {
 3669:       $request=new HTTP::Request('POST',$host.$fn);
 3670:       $request->content(join('&',map { 
 3671:             my $name = escape($_);
 3672:             "$name=" . ( ref($form{$_}) eq 'ARRAY' 
 3673:             ? join("&$name=", map {escape($_) } @{$form{$_}}) 
 3674:             : &escape($form{$_}) );    
 3675:         } keys(%form)));
 3676:     } else {
 3677:       $request=new HTTP::Request('GET',$host.$fn);
 3678:     }
 3679: 
 3680:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
 3681:     my $lonhost = $perlvar{'lonHostID'};
 3682:     my $islocal;
 3683:     if (($env{'request.course.id'}) &&
 3684:         ($form{'grade_courseid'} eq $env{'request.course.id'}) &&
 3685:         ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
 3686:         ($form{'grade_symb'} ne '') &&
 3687:         (&allowed('mgr',$env{'request.course.id'}.
 3688:                         ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
 3689:         $islocal = 1;
 3690:     }
 3691:     $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
 3692:                                              '','','',$islocal);
 3693: 
 3694:     if (wantarray) {
 3695: 	return ($response->content, $response);
 3696:     } else {
 3697: 	return $response->content;
 3698:     }
 3699: }
 3700: 
 3701: sub externalssi {
 3702:     my ($url)=@_;
 3703:     my $request=new HTTP::Request('GET',$url);
 3704:     my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
 3705:     if (wantarray) {
 3706:         return ($response->content, $response);
 3707:     } else {
 3708:         return $response->content;
 3709:     }
 3710: }
 3711: 
 3712: 
 3713: # If the local copy of a replicated resource is outdated, trigger a  
 3714: # connection from the homeserver to flush the delayed queue. If no update 
 3715: # happens, remove local copies of outdated resource (and corresponding
 3716: # metadata file).
 3717: 
 3718: sub remove_stale_resfile {
 3719:     my ($url) = @_;
 3720:     my $removed;
 3721:     if ($url=~m{^/res/($match_domain)/($match_username)/}) {
 3722:         my $audom = $1;
 3723:         my $auname = $2;
 3724:         unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
 3725:             my $homeserver = &homeserver($auname,$audom);
 3726:             unless (($homeserver eq 'no_host') ||
 3727:                     (grep { $_ eq $homeserver } &current_machine_ids())) {
 3728:                 my $fname = &filelocation('',$url);
 3729:                 if (-e $fname) {
 3730:                     my $hostname = &hostname($homeserver);
 3731:                     if ($hostname) {
 3732:                         my $protocol = $protocol{$homeserver};
 3733:                         $protocol = 'http' if ($protocol ne 'https');
 3734:                         my $uri = &declutter($url);
 3735:                         my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
 3736:                         my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
 3737:                         if ($response->is_success()) {
 3738:                             my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
 3739:                             my $locmodtime = (stat($fname))[9];
 3740:                             if ($locmodtime < $remmodtime) {
 3741:                                 my $stale;
 3742:                                 my $answer = &reply('pong',$homeserver);
 3743:                                 if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
 3744:                                     sleep(0.2);
 3745:                                     $locmodtime = (stat($fname))[9];
 3746:                                     if ($locmodtime < $remmodtime) {
 3747:                                         my $posstransfer = $fname.'.in.transfer';
 3748:                                         if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
 3749:                                             $removed = 1;
 3750:                                         } else {
 3751:                                             $stale = 1;
 3752:                                         }
 3753:                                     } else {
 3754:                                         $removed = 1;
 3755:                                     }
 3756:                                 } else {
 3757:                                     $stale = 1;
 3758:                                 }
 3759:                                 if ($stale) {
 3760:                                     if (unlink($fname)) {
 3761:                                         if ($uri!~/\.meta$/) {
 3762:                                             if (-e $fname.'.meta') {
 3763:                                                 unlink($fname.'.meta');
 3764:                                             }
 3765:                                         }
 3766:                                         my $unsubresult = &unsubscribe($fname);
 3767:                                         unless ($unsubresult eq 'ok') {
 3768:                                             &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
 3769:                                         }
 3770:                                         $removed = 1;
 3771:                                     }
 3772:                                 }
 3773:                             }
 3774:                         }
 3775:                     }
 3776:                 }
 3777:             }
 3778:         }
 3779:     }
 3780:     return $removed;
 3781: }
 3782: 
 3783: # -------------------------------- Allow a /uploaded/ URI to be vouched for
 3784: 
 3785: sub allowuploaded {
 3786:     my ($srcurl,$url)=@_;
 3787:     $url=&clutter(&declutter($url));
 3788:     my $dir=$url;
 3789:     $dir=~s/\/[^\/]+$//;
 3790:     my %httpref=();
 3791:     my $httpurl=&hreflocation('',$url);
 3792:     $httpref{'httpref.'.$httpurl}=$srcurl;
 3793:     &Apache::lonnet::appenv(\%httpref);
 3794: }
 3795: 
 3796: #
 3797: # Determine if the current user should be able to edit a particular resource,
 3798: # when viewing in course context.
 3799: # (a) When viewing resource used to determine if "Edit" item is included in 
 3800: #     Functions.
 3801: # (b) When displaying folder contents in course editor, used to determine if
 3802: #     "Edit" link will be displayed alongside resource.
 3803: #
 3804: #  input: six args -- filename (decluttered), course number, course domain,
 3805: #                   url, symb (if registered) and group (if this is a group
 3806: #                   item -- e.g., bulletin board, group page etc.).
 3807: #  output: array of five scalars -- 
 3808: #          $cfile -- url for file editing if editable on current server
 3809: #          $home -- homeserver of resource (i.e., for author if published,
 3810: #                                           or course if uploaded.).
 3811: #          $switchserver --  1 if server switch will be needed.
 3812: #          $forceedit -- 1 if icon/link should be to go to edit mode 
 3813: #          $forceview -- 1 if icon/link should be to go to view mode
 3814: #
 3815: 
 3816: sub can_edit_resource {
 3817:     my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_;
 3818:     my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse);
 3819: #
 3820: # For aboutme pages user can only edit his/her own.
 3821: #
 3822:     if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) {
 3823:         my ($sdom,$sname) = ($1,$2);
 3824:         if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) {
 3825:             $home = $env{'user.home'};
 3826:             $cfile = $resurl;
 3827:             if ($env{'form.forceedit'}) {
 3828:                 $forceview = 1;
 3829:             } else {
 3830:                 $forceedit = 1;
 3831:             }
 3832:             return ($cfile,$home,$switchserver,$forceedit,$forceview);
 3833:         } else {
 3834:             return;
 3835:         }
 3836:     }
 3837: 
 3838:     if ($env{'request.course.id'}) {
 3839:         my $crsedit = &allowed('mdc',$env{'request.course.id'});
 3840:         if ($group ne '') {
 3841: # if this is a group homepage or group bulletin board, check group privs
 3842:             my $allowed = 0;
 3843:             if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) {
 3844:                 if ((&allowed('mdg',$env{'request.course.id'}.
 3845:                               ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
 3846:                         (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
 3847:                     $allowed = 1;
 3848:                 }
 3849:             } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) {
 3850:                 if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
 3851:                         (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
 3852:                     $allowed = 1;
 3853:                 }
 3854:             }
 3855:             if ($allowed) {
 3856:                 $home=&homeserver($cnum,$cdom);
 3857:                 if ($env{'form.forceedit'}) {
 3858:                     $forceview = 1;
 3859:                 } else {
 3860:                     $forceedit = 1;
 3861:                 }
 3862:                 $cfile = $resurl;
 3863:             } else {
 3864:                 return;
 3865:             }
 3866:         } else {
 3867:             if ($resurl =~ m{^/?adm/viewclasslist$}) {
 3868:                 unless (&allowed('opa',$env{'request.course.id'})) {
 3869:                     return;
 3870:                 }
 3871:             } elsif (!$crsedit) {
 3872:                 if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
 3873: #
 3874: # No edit allowed where CC has switched to student role.
 3875: #
 3876:                     return;
 3877:                 } elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) ||
 3878:                          ($resurl =~ m{^/res/lib/templates/})) {
 3879:                     return;
 3880:                 }
 3881:             }
 3882:         }
 3883:     }
 3884: 
 3885:     if ($file ne '') {
 3886:         if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {
 3887:             if (&is_course_upload($file,$cnum,$cdom)) {
 3888:                 $uploaded = 1;
 3889:                 $incourse = 1;
 3890:                 if ($file =~/\.(htm|html|css|js|txt)$/) {
 3891:                     $cfile = &hreflocation('',$file);
 3892:                     if ($env{'form.forceedit'}) {
 3893:                         $forceview = 1;
 3894:                     } else {
 3895:                         $forceedit = 1;
 3896:                     }
 3897:                 }
 3898:             } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {
 3899:                 $incourse = 1;
 3900:                 if ($env{'form.forceedit'}) {
 3901:                     $forceview = 1;
 3902:                 } else {
 3903:                     $forceedit = 1;
 3904:                 }
 3905:                 $cfile = $resurl;
 3906:             } elsif (($resurl ne '') && (&is_on_map($resurl))) {
 3907:                 if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
 3908:                     $incourse = 1;
 3909:                     if ($env{'form.forceedit'}) {
 3910:                         $forceview = 1;
 3911:                     } else {
 3912:                         $forceedit = 1;
 3913:                     }
 3914:                     $cfile = $resurl;
 3915:                 } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') {
 3916:                     $incourse = 1;
 3917:                     $cfile = $resurl.'/smpedit';
 3918:                 } elsif ($resurl =~ m{^/adm/wrapper/ext/}) {
 3919:                     $incourse = 1;
 3920:                     if ($env{'form.forceedit'}) {
 3921:                         $forceview = 1;
 3922:                     } else {
 3923:                         $forceedit = 1;
 3924:                     }
 3925:                     $cfile = $resurl;
 3926:                 } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
 3927:                     my ($map,$id,$res) = &decode_symb($symb);
 3928:                     if ($map =~ /\.page$/) {
 3929:                         $incourse = 1;
 3930:                         if ($env{'form.forceedit'}) {
 3931:                             $forceview = 1;
 3932:                             $cfile = $map;
 3933:                         } else {
 3934:                             $forceedit = 1;
 3935:                             $cfile =  '/adm/wrapper'.$resurl;
 3936:                         }
 3937:                     }
 3938:                 } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
 3939:                     $incourse = 1;
 3940:                     if ($env{'form.forceedit'}) {
 3941:                         $forceview = 1;
 3942:                     } else {
 3943:                         $forceedit = 1;
 3944:                     }
 3945:                     $cfile = $resurl;
 3946:                 } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
 3947:                     $incourse = 1;
 3948:                     if ($env{'form.forceedit'}) {
 3949:                         $forceview = 1;
 3950:                     } else {
 3951:                         $forceedit = 1;
 3952:                     }
 3953:                     $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
 3954:                 }
 3955:             } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
 3956:                 my $template = '/res/lib/templates/simpleproblem.problem';
 3957:                 if (&is_on_map($template)) { 
 3958:                     $incourse = 1;
 3959:                     $forceview = 1;
 3960:                     $cfile = $template;
 3961:                 }
 3962:             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
 3963:                 $incourse = 1;
 3964:                 if ($env{'form.forceedit'}) {
 3965:                     $forceview = 1;
 3966:                 } else {
 3967:                     $forceedit = 1;
 3968:                 }
 3969:                 $cfile = $resurl;
 3970:             } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
 3971:                 $incourse = 1;
 3972:                 if ($env{'form.forceedit'}) {
 3973:                     $forceview = 1;
 3974:                 } else {
 3975:                     $forceedit = 1;
 3976:                 }
 3977:                 $cfile = $resurl;
 3978:             } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
 3979:                 $incourse = 1;
 3980:                 $forceview = 1;
 3981:                 if ($symb) {
 3982:                     my ($map,$id,$res)=&decode_symb($symb);
 3983:                     $env{'request.symb'} = $symb;
 3984:                     $cfile = &clutter($res);
 3985:                 } else {
 3986:                     $cfile = $env{'form.suppurl'};
 3987:                     my $escfile = &unescape($cfile);
 3988:                     if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
 3989:                         $cfile = '/adm/wrapper'.$escfile;
 3990:                     } else {
 3991:                         $escfile =~ s{^http://}{};
 3992:                         $cfile = &escape("/adm/wrapper/ext/$escfile");
 3993:                     }
 3994:                 }
 3995:             } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
 3996:                 if ($env{'form.forceedit'}) {
 3997:                     $forceview = 1;
 3998:                 } else {
 3999:                     $forceedit = 1;
 4000:                 }
 4001:                 $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
 4002:             }
 4003:         }
 4004:         if ($uploaded || $incourse) {
 4005:             $home=&homeserver($cnum,$cdom);
 4006:         } elsif ($file !~ m{/$}) {
 4007:             $file=~s{^(priv/$match_domain/$match_username)}{/$1};
 4008:             $file=~s{^($match_domain/$match_username)}{/priv/$1};
 4009:             # Check that the user has permission to edit this resource
 4010:             my $setpriv = 1;
 4011:             my ($cfuname,$cfudom)=&constructaccess($file,$setpriv);
 4012:             if (defined($cfudom)) {
 4013:                 $home=&homeserver($cfuname,$cfudom);
 4014:                 $cfile=$file;
 4015:             }
 4016:         }
 4017:         if (($cfile ne '') && (!$incourse || $uploaded) && 
 4018:             (($home ne '') && ($home ne 'no_host'))) {
 4019:             my @ids=&current_machine_ids();
 4020:             unless (grep(/^\Q$home\E$/,@ids)) {
 4021:                 $switchserver=1;
 4022:             }
 4023:         }
 4024:     }
 4025:     return ($cfile,$home,$switchserver,$forceedit,$forceview);
 4026: }
 4027: 
 4028: sub is_course_upload {
 4029:     my ($file,$cnum,$cdom) = @_;
 4030:     my $uploadpath = &LONCAPA::propath($cdom,$cnum);
 4031:     $uploadpath =~ s{^\/}{};
 4032:     if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||
 4033:         ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {
 4034:         return 1;
 4035:     }
 4036:     return;
 4037: }
 4038: 
 4039: sub in_course {
 4040:     my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;
 4041:     if ($hideprivileged) {
 4042:         my $skipuser;
 4043:         my %coursehash = &coursedescription($cdom.'_'.$cnum);
 4044:         my @possdoms = ($cdom);  
 4045:         if ($coursehash{'checkforpriv'}) { 
 4046:             push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); 
 4047:         }
 4048:         if (&privileged($uname,$udom,\@possdoms)) {
 4049:             $skipuser = 1;
 4050:             if ($coursehash{'nothideprivileged'}) {
 4051:                 foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
 4052:                     my $user;
 4053:                     if ($item =~ /:/) {
 4054:                         $user = $item;
 4055:                     } else {
 4056:                         $user = join(':',split(/[\@]/,$item));
 4057:                     }
 4058:                     if ($user eq $uname.':'.$udom) {
 4059:                         undef($skipuser);
 4060:                         last;
 4061:                     }
 4062:                 }
 4063:             }
 4064:             if ($skipuser) {
 4065:                 return 0;
 4066:             }
 4067:         }
 4068:     }
 4069:     $type ||= 'any';
 4070:     if (!defined($cdom) || !defined($cnum)) {
 4071:         my $cid  = $env{'request.course.id'};
 4072:         $cdom = $env{'course.'.$cid.'.domain'};
 4073:         $cnum = $env{'course.'.$cid.'.num'};
 4074:     }
 4075:     my $typesref;
 4076:     if (($type eq 'any') || ($type eq 'all')) {
 4077:         $typesref = ['active','previous','future'];
 4078:     } elsif ($type eq 'previous' || $type eq 'future') {
 4079:         $typesref = [$type];
 4080:     }
 4081:     my %roles = &get_my_roles($uname,$udom,'userroles',
 4082:                               $typesref,undef,[$cdom]);
 4083:     my ($tmp) = keys(%roles);
 4084:     return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i);
 4085:     my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles));
 4086:     if (@course_roles > 0) {
 4087:         return 1;
 4088:     }
 4089:     return 0;
 4090: }
 4091: 
 4092: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 4093: # input: action, courseID, current domain, intended
 4094: #        path to file, source of file, instruction to parse file for objects,
 4095: #        ref to hash for embedded objects,
 4096: #        ref to hash for codebase of java objects.
 4097: #        reference to scalar to accommodate mime type determined
 4098: #          from File::MMagic if $parser = parse.
 4099: #
 4100: # output: url to file (if action was uploaddoc), 
 4101: #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
 4102: #
 4103: # Allows directory structure to be used within lonUsers/../userfiles/ for a 
 4104: # course.
 4105: #
 4106: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 4107: #          will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
 4108: #          course's home server.
 4109: #
 4110: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
 4111: #          be copied from $source (current location) to 
 4112: #          /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 4113: #         and will then be copied to
 4114: #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
 4115: #         course's home server.
 4116: #
 4117: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 4118: #         will be retrived from $env{form.uploaddoc} (from DOCS interface) to
 4119: #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 4120: #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
 4121: #         in course's home server.
 4122: #
 4123: 
 4124: sub process_coursefile {
 4125:     my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase,
 4126:         $mimetype)=@_;
 4127:     my $fetchresult;
 4128:     my $home=&homeserver($docuname,$docudom);
 4129:     if ($action eq 'propagate') {
 4130:         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 4131: 			     $home);
 4132:     } else {
 4133:         my $fpath = '';
 4134:         my $fname = $file;
 4135:         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
 4136:         $fpath=$docudom.'/'.$docuname.'/'.$fpath;
 4137:         my $filepath = &build_filepath($fpath);
 4138:         if ($action eq 'copy') {
 4139:             if ($source eq '') {
 4140:                 $fetchresult = 'no source file';
 4141:                 return $fetchresult;
 4142:             } else {
 4143:                 my $destination = $filepath.'/'.$fname;
 4144:                 rename($source,$destination);
 4145:                 $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 4146:                                  $home);
 4147:             }
 4148:         } elsif ($action eq 'uploaddoc') {
 4149:             open(my $fh,'>',$filepath.'/'.$fname);
 4150:             print $fh $env{'form.'.$source};
 4151:             close($fh);
 4152:             if ($parser eq 'parse') {
 4153:                 my $mm = new File::MMagic;
 4154:                 my $type = $mm->checktype_filename($filepath.'/'.$fname);
 4155:                 if ($type eq 'text/html') {
 4156:                     my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
 4157:                     unless ($parse_result eq 'ok') {
 4158:                         &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
 4159:                     }
 4160:                 }
 4161:                 if (ref($mimetype)) {
 4162:                     $$mimetype = $type;
 4163:                 } 
 4164:             }
 4165:             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 4166:                                  $home);
 4167:             if ($fetchresult eq 'ok') {
 4168:                 return '/uploaded/'.$fpath.'/'.$fname;
 4169:             } else {
 4170:                 &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 4171:                         ' to host '.$home.': '.$fetchresult);
 4172:                 return '/adm/notfound.html';
 4173:             }
 4174:         }
 4175:     }
 4176:     unless ( $fetchresult eq 'ok') {
 4177:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 4178:              ' to host '.$home.': '.$fetchresult);
 4179:     }
 4180:     return $fetchresult;
 4181: }
 4182: 
 4183: sub build_filepath {
 4184:     my ($fpath) = @_;
 4185:     my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
 4186:     unless ($fpath eq '') {
 4187:         my @parts=split('/',$fpath);
 4188:         foreach my $part (@parts) {
 4189:             $filepath.= '/'.$part;
 4190:             if ((-e $filepath)!=1) {
 4191:                 mkdir($filepath,0777);
 4192:             }
 4193:         }
 4194:     }
 4195:     return $filepath;
 4196: }
 4197: 
 4198: sub store_edited_file {
 4199:     my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
 4200:     my $file = $primary_url;
 4201:     $file =~ s#^/uploaded/$docudom/$docuname/##;
 4202:     my $fpath = '';
 4203:     my $fname = $file;
 4204:     ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
 4205:     $fpath=$docudom.'/'.$docuname.'/'.$fpath;
 4206:     my $filepath = &build_filepath($fpath);
 4207:     open(my $fh,'>',$filepath.'/'.$fname);
 4208:     print $fh $content;
 4209:     close($fh);
 4210:     my $home=&homeserver($docuname,$docudom);
 4211:     $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
 4212: 			  $home);
 4213:     if ($$fetchresult eq 'ok') {
 4214:         return '/uploaded/'.$fpath.'/'.$fname;
 4215:     } else {
 4216:         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
 4217: 		 ' to host '.$home.': '.$$fetchresult);
 4218:         return '/adm/notfound.html';
 4219:     }
 4220: }
 4221: 
 4222: sub clean_filename {
 4223:     my ($fname,$args)=@_;
 4224: # Replace Windows backslashes by forward slashes
 4225:     $fname=~s/\\/\//g;
 4226:     if (!$args->{'keep_path'}) {
 4227:         # Get rid of everything but the actual filename
 4228: 	$fname=~s/^.*\/([^\/]+)$/$1/;
 4229:     }
 4230: # Replace spaces by underscores
 4231:     $fname=~s/\s+/\_/g;
 4232: # Transliterate non-ascii text to ascii
 4233:     my $lang = &Apache::lonlocal::current_language();
 4234:     $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang);
 4235: # Replace all other weird characters by nothing
 4236:     $fname=~s{[^/\w\.\-]}{}g;
 4237: # Replace all .\d. sequences with _\d. so they no longer look like version
 4238: # numbers
 4239:     $fname=~s/\.(\d+)(?=\.)/_$1/g;
 4240: # Replace three or more adjacent underscores with one for consistency 
 4241: # with loncfile::filename_check() so complete url can be extracted by
 4242: # lonnet::decode_symb()
 4243:     $fname=~s/_{3,}/_/g;
 4244:     return $fname;
 4245: }
 4246: 
 4247: # This Function checks if an Image's dimensions exceed either $resizewidth (width) 
 4248: # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an 
 4249: # image with the same aspect ratio as the original, but with dimensions which do 
 4250: # not exceed $resizewidth and $resizeheight.
 4251:  
 4252: sub resizeImage {
 4253:     my ($img_path,$resizewidth,$resizeheight) = @_;
 4254:     my $ima = Image::Magick->new;
 4255:     my $resized;
 4256:     if (-e $img_path) {
 4257:         $ima->Read($img_path);
 4258:         if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) {
 4259:             my $width = $ima->Get('width');
 4260:             my $height = $ima->Get('height');
 4261:             if ($width > $resizewidth) {
 4262: 	        my $factor = $width/$resizewidth;
 4263:                 my $newheight = $height/$factor;
 4264:                 $ima->Scale(width=>$resizewidth,height=>$newheight);
 4265:                 $resized = 1;
 4266:             }
 4267:         }
 4268:         if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) {
 4269:             my $width = $ima->Get('width');
 4270:             my $height = $ima->Get('height');
 4271:             if ($height > $resizeheight) {
 4272:                 my $factor = $height/$resizeheight;
 4273:                 my $newwidth = $width/$factor;
 4274:                 $ima->Scale(width=>$newwidth,height=>$resizeheight);
 4275:                 $resized = 1;
 4276:             }
 4277:         }
 4278:         if ($resized) {
 4279:             $ima->Write($img_path);
 4280:         }
 4281:     }
 4282:     return;
 4283: }
 4284: 
 4285: # --------------- Take an uploaded file and put it into the userfiles directory
 4286: # input: $formname - the contents of the file are in $env{"form.$formname"}
 4287: #                    the desired filename is in $env{"form.$formname.filename"}
 4288: #        $context - possible values: coursedoc, existingfile, overwrite, 
 4289: #                                    canceloverwrite, scantron, toollogo  or ''.
 4290: #                   if 'coursedoc': upload to the current course
 4291: #                   if 'existingfile': write file to tmp/overwrites directory 
 4292: #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
 4293: #                   $context is passed as argument to &finishuserfileupload
 4294: #        $subdir - directory in userfile to store the file into
 4295: #        $parser - instruction to parse file for objects ($parser = parse) or
 4296: #                  if context is 'scantron', $parser is hashref of csv column mapping
 4297: #                  (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3, 
 4298: #                          Section => 4, CODE => 5, FirstQuestion => 9 }).
 4299: #        $allfiles - reference to hash for embedded objects
 4300: #        $codebase - reference to hash for codebase of java objects
 4301: #        $destuname - username for permanent storage of uploaded file
 4302: #        $destudom - domain for permanaent storage of uploaded file
 4303: #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image 
 4304: #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
 4305: #        $resizewidth - width (pixels) to which to resize uploaded image
 4306: #        $resizeheight - height (pixels) to which to resize uploaded image
 4307: #        $mimetype - reference to scalar to accommodate mime type determined
 4308: #                    from File::MMagic.
 4309: # 
 4310: # output: url of file in userspace, or error: <message> 
 4311: #             or /adm/notfound.html if failure to upload occurse
 4312: 
 4313: sub userfileupload {
 4314:     my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname,
 4315:         $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$mimetype)=@_;
 4316:     if (!defined($subdir)) { $subdir='unknown'; }
 4317:     my $fname=$env{'form.'.$formname.'.filename'};
 4318:     $fname=&clean_filename($fname);
 4319:     # See if there is anything left
 4320:     unless ($fname) { return 'error: no uploaded file'; }
 4321:     # If filename now begins with a . prepend unix timestamp _ milliseconds
 4322:     if ($fname =~ /^\./) {
 4323:         my ($s,$usec) = &gettimeofday();
 4324:         while (length($usec) < 6) {
 4325:             $usec = '0'.$usec;
 4326:         }
 4327:         $fname = $s.'_'.substr($usec,0,3).$fname;
 4328:     }
 4329:     # Files uploaded to help request form, or uploaded to "create course" page are handled differently
 4330:     if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
 4331:         (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
 4332:          ($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
 4333:         my $now = time;
 4334:         my $filepath;
 4335:         if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {
 4336:              $filepath = 'tmp/helprequests/'.$now;
 4337:         } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {
 4338:              $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
 4339:                          '_'.$env{'user.domain'}.'/pending';
 4340:         } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
 4341:             my ($docuname,$docudom);
 4342:             if ($destudom =~ /^$match_domain$/) {
 4343:                 $docudom = $destudom;
 4344:             } else {
 4345:                 $docudom = $env{'user.domain'};
 4346:             }
 4347:             if ($destuname =~ /^$match_username$/) {
 4348:                 $docuname = $destuname;
 4349:             } else {
 4350:                 $docuname = $env{'user.name'};
 4351:             }
 4352:             if (exists($env{'form.group'})) {
 4353:                 $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
 4354:                 $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 4355:             }
 4356:             $filepath = 'tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$subdir;
 4357:             if ($context eq 'canceloverwrite') {
 4358:                 my $tempfile =  $perlvar{'lonDaemons'}.'/'.$filepath.'/'.$fname;
 4359:                 if (-e  $tempfile) {
 4360:                     my @info = stat($tempfile);
 4361:                     if ($info[9] eq $env{'form.timestamp'}) {
 4362:                         unlink($tempfile);
 4363:                     }
 4364:                 }
 4365:                 return;
 4366:             }
 4367:         }
 4368:         # Create the directory if not present
 4369:         my @parts=split(/\//,$filepath);
 4370:         my $fullpath = $perlvar{'lonDaemons'};
 4371:         for (my $i=0;$i<@parts;$i++) {
 4372:             $fullpath .= '/'.$parts[$i];
 4373:             if ((-e $fullpath)!=1) {
 4374:                 mkdir($fullpath,0777);
 4375:             }
 4376:         }
 4377:         open(my $fh,'>',$fullpath.'/'.$fname);
 4378:         print $fh $env{'form.'.$formname};
 4379:         close($fh);
 4380:         if ($context eq 'existingfile') {
 4381:             my @info = stat($fullpath.'/'.$fname);
 4382:             return ($fullpath.'/'.$fname,$info[9]);
 4383:         } else {
 4384:             return $fullpath.'/'.$fname;
 4385:         }
 4386:     }
 4387:     if ($subdir eq 'scantron') {
 4388:         $fname = 'scantron_orig_'.$fname;
 4389:     } else {
 4390:         $fname="$subdir/$fname";
 4391:     }
 4392:     if ($context eq 'coursedoc') {
 4393: 	my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
 4394: 	my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 4395:         if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
 4396:             return &finishuserfileupload($docuname,$docudom,
 4397: 					 $formname,$fname,$parser,$allfiles,
 4398: 					 $codebase,$thumbwidth,$thumbheight,
 4399:                                          $resizewidth,$resizeheight,$context,$mimetype);
 4400:         } else {
 4401:             if ($env{'form.folder'}) {
 4402:                 $fname=$env{'form.folder'}.'/'.$fname;
 4403:             }
 4404:             return &process_coursefile('uploaddoc',$docuname,$docudom,
 4405: 				       $fname,$formname,$parser,
 4406: 				       $allfiles,$codebase,$mimetype);
 4407:         }
 4408:     } elsif (defined($destuname)) {
 4409:         my $docuname=$destuname;
 4410:         my $docudom=$destudom;
 4411: 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
 4412: 				     $parser,$allfiles,$codebase,
 4413:                                      $thumbwidth,$thumbheight,
 4414:                                      $resizewidth,$resizeheight,$context,$mimetype);
 4415:     } else {
 4416:         my $docuname=$env{'user.name'};
 4417:         my $docudom=$env{'user.domain'};
 4418:         if ((exists($env{'form.group'})) || ($context eq 'syllabus')) {
 4419:             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
 4420:             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 4421:         }
 4422: 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
 4423: 				     $parser,$allfiles,$codebase,
 4424:                                      $thumbwidth,$thumbheight,
 4425:                                      $resizewidth,$resizeheight,$context,$mimetype);
 4426:     }
 4427: }
 4428: 
 4429: sub finishuserfileupload {
 4430:     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
 4431:         $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_;
 4432:     my $path=$docudom.'/'.$docuname.'/';
 4433:     my $filepath=$perlvar{'lonDocRoot'};
 4434:   
 4435:     my ($fnamepath,$file,$fetchthumb);
 4436:     $file=$fname;
 4437:     if ($fname=~m|/|) {
 4438:         ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
 4439: 	$path.=$fnamepath.'/';
 4440:     }
 4441:     my @parts=split(/\//,$filepath.'/userfiles/'.$path);
 4442:     my $count;
 4443:     for ($count=4;$count<=$#parts;$count++) {
 4444:         $filepath.="/$parts[$count]";
 4445:         if ((-e $filepath)!=1) {
 4446: 	    mkdir($filepath,0777);
 4447:         }
 4448:     }
 4449: 
 4450: # Save the file
 4451:     {
 4452: 	if (!open(FH,'>',$filepath.'/'.$file)) {
 4453: 	    &logthis('Failed to create '.$filepath.'/'.$file);
 4454: 	    print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
 4455: 	    return '/adm/notfound.html';
 4456: 	}
 4457:         if ($context eq 'overwrite') {
 4458:             my $source =  LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
 4459:             my $target = $filepath.'/'.$file;
 4460:             if (-e $source) {
 4461:                 my @info = stat($source);
 4462:                 if ($info[9] eq $env{'form.timestamp'}) {   
 4463:                     unless (&File::Copy::move($source,$target)) {
 4464:                         &logthis('Failed to overwrite '.$filepath.'/'.$file);
 4465:                         return "Moving from $source failed";
 4466:                     }
 4467:                 } else {
 4468:                     return "Temporary file: $source had unexpected date/time for last modification";
 4469:                 }
 4470:             } else {
 4471:                 return "Temporary file: $source missing";
 4472:             }
 4473:         } elsif (!print FH ($env{'form.'.$formname})) {
 4474: 	    &logthis('Failed to write to '.$filepath.'/'.$file);
 4475: 	    print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
 4476: 	    return '/adm/notfound.html';
 4477: 	}
 4478: 	close(FH);
 4479:         if ($resizewidth && $resizeheight) {
 4480:             my $mm = new File::MMagic;
 4481:             my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
 4482:             if ($mime_type =~ m{^image/}) {
 4483: 	        &resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight);
 4484:             }  
 4485: 	}
 4486:     }
 4487:     if (($context eq 'coursedoc') || ($parser eq 'parse')) {
 4488:         if (ref($mimetype)) {
 4489:             if ($$mimetype eq '') {
 4490:                 my $mm = new File::MMagic;
 4491:                 my $type = $mm->checktype_filename($filepath.'/'.$file);
 4492:                 $$mimetype = $type;
 4493:             }
 4494:         }
 4495:     }
 4496:     if (($context ne 'scantron') && ($parser eq 'parse')) {
 4497:         if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
 4498:             my $parse_result = &extract_embedded_items($filepath.'/'.$file,
 4499:                                                        $allfiles,$codebase);
 4500:             unless ($parse_result eq 'ok') {
 4501:                 &logthis('Failed to parse '.$filepath.$file.
 4502: 	   	         ' for embedded media: '.$parse_result); 
 4503:             }
 4504:         }
 4505:     } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) {
 4506:         my $format = $env{'form.scantron_format'};
 4507:         &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format);
 4508:     }
 4509:     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
 4510:         my $input = $filepath.'/'.$file;
 4511:         my $output = $filepath.'/'.'tn-'.$file;
 4512:         my $makethumb; 
 4513:         my $thumbsize = $thumbwidth.'x'.$thumbheight;
 4514:         if ($context eq 'toollogo') {
 4515:             my ($fullwidth,$fullheight) = &check_dimensions($input);
 4516:             if ($fullwidth ne '' && $fullheight ne '') {
 4517:                 if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {
 4518:                     $makethumb = 1;
 4519:                 }
 4520:             }
 4521:         } else {
 4522:             $makethumb = 1;
 4523:         }
 4524:         if ($makethumb) {
 4525:             my @args = ('convert','-sample',$thumbsize,$input,$output);
 4526:             system({$args[0]} @args);
 4527:             if (-e $filepath.'/'.'tn-'.$file) {
 4528:                 $fetchthumb  = 1; 
 4529:             }
 4530:         }
 4531:     }
 4532:  
 4533: # Notify homeserver to grep it
 4534: #
 4535:     my $docuhome=&homeserver($docuname,$docudom);	
 4536:     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
 4537:     if ($fetchresult eq 'ok') {
 4538:         if ($fetchthumb) {
 4539:             my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
 4540:             if ($thumbresult ne 'ok') {
 4541:                 &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
 4542:                          $docuhome.': '.$thumbresult);
 4543:             }
 4544:         }
 4545: #
 4546: # Return the URL to it
 4547:         return '/uploaded/'.$path.$file;
 4548:     } else {
 4549:         &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
 4550: 		 ': '.$fetchresult);
 4551:         return '/adm/notfound.html';
 4552:     }
 4553: }
 4554: 
 4555: sub extract_embedded_items {
 4556:     my ($fullpath,$allfiles,$codebase,$content) = @_;
 4557:     my @state = ();
 4558:     my (%lastids,%related,%shockwave,%flashvars);
 4559:     my %javafiles = (
 4560:                       codebase => '',
 4561:                       code => '',
 4562:                       archive => ''
 4563:                     );
 4564:     my %mediafiles = (
 4565:                       src => '',
 4566:                       movie => '',
 4567:                      );
 4568:     my $p;
 4569:     if ($content) {
 4570:         $p = HTML::LCParser->new($content);
 4571:     } else {
 4572:         $p = HTML::LCParser->new($fullpath);
 4573:     }
 4574:     while (my $t=$p->get_token()) {
 4575: 	if ($t->[0] eq 'S') {
 4576: 	    my ($tagname, $attr) = ($t->[1],$t->[2]);
 4577: 	    push(@state, $tagname);
 4578:             if (lc($tagname) eq 'allow') {
 4579:                 &add_filetype($allfiles,$attr->{'src'},'src');
 4580:             }
 4581: 	    if (lc($tagname) eq 'img') {
 4582: 		&add_filetype($allfiles,$attr->{'src'},'src');
 4583: 	    }
 4584: 	    if (lc($tagname) eq 'a') {
 4585:                 unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
 4586:                     &add_filetype($allfiles,$attr->{'href'},'href');
 4587:                 }
 4588: 	    }
 4589:             if (lc($tagname) eq 'script') {
 4590:                 my $src;
 4591:                 if ($attr->{'archive'} =~ /\.jar$/i) {
 4592:                     &add_filetype($allfiles,$attr->{'archive'},'archive');
 4593:                 } else {
 4594:                     if ($attr->{'src'} ne '') {
 4595:                         $src = $attr->{'src'};
 4596:                         &add_filetype($allfiles,$src,'src');
 4597:                     }
 4598:                 }
 4599:                 my $text = $p->get_trimmed_text();
 4600:                 if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
 4601:                     my @swfargs = split(/,/,$1);
 4602:                     foreach my $item (@swfargs) {
 4603:                         $item =~ s/["']//g;
 4604:                         $item =~ s/^\s+//;
 4605:                         $item =~ s/\s+$//;
 4606:                     }
 4607:                     if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
 4608:                         if (ref($related{$swfargs[0]}) eq 'ARRAY') {
 4609:                             push(@{$related{$swfargs[0]}},$swfargs[2]);
 4610:                         } else {
 4611:                             $related{$swfargs[0]} = [$swfargs[2]];
 4612:                         }
 4613:                     }
 4614:                 }
 4615:             }
 4616:             if (lc($tagname) eq 'link') {
 4617:                 if (lc($attr->{'rel'}) eq 'stylesheet') { 
 4618:                     &add_filetype($allfiles,$attr->{'href'},'href');
 4619:                 }
 4620:             }
 4621: 	    if (lc($tagname) eq 'object' ||
 4622: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
 4623: 		foreach my $item (keys(%javafiles)) {
 4624: 		    $javafiles{$item} = '';
 4625: 		}
 4626:                 if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
 4627:                     $lastids{lc($tagname)} = $attr->{'id'};
 4628:                 }
 4629: 	    }
 4630: 	    if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
 4631: 		my $name = lc($attr->{'name'});
 4632: 		foreach my $item (keys(%javafiles)) {
 4633: 		    if ($name eq $item) {
 4634: 			$javafiles{$item} = $attr->{'value'};
 4635: 			last;
 4636: 		    }
 4637: 		}
 4638:                 my $pathfrom;
 4639: 		foreach my $item (keys(%mediafiles)) {
 4640: 		    if ($name eq $item) {
 4641:                         $pathfrom = $attr->{'value'};
 4642:                         $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
 4643: 			&add_filetype($allfiles,$pathfrom,$name);
 4644: 			last;
 4645: 		    }
 4646: 		}
 4647:                 if ($name eq 'flashvars') {
 4648:                     $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
 4649:                 }
 4650:                 if ($pathfrom ne '') {
 4651:                     &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
 4652:                                          $pathfrom);
 4653:                 }
 4654: 	    }
 4655: 	    if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
 4656: 		foreach my $item (keys(%javafiles)) {
 4657: 		    if ($attr->{$item}) {
 4658: 			$javafiles{$item} = $attr->{$item};
 4659: 			last;
 4660: 		    }
 4661: 		}
 4662: 		foreach my $item (keys(%mediafiles)) {
 4663: 		    if ($attr->{$item}) {
 4664: 			&add_filetype($allfiles,$attr->{$item},$item);
 4665: 			last;
 4666: 		    }
 4667: 		}
 4668:                 if (lc($tagname) eq 'embed') {
 4669:                     if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
 4670:                         &embedded_dependency($allfiles,\%related,$attr->{'name'},
 4671:                                              $attr->{'src'});
 4672:                     }
 4673:                 }
 4674: 	    }
 4675:             if (lc($tagname) eq 'iframe') {
 4676:                 my $src = $attr->{'src'} ;
 4677:                 if (($src ne '') && ($src !~ m{^(/|https?://)})) {
 4678:                     &add_filetype($allfiles,$src,'src');
 4679:                 } elsif ($src =~ m{^/}) {
 4680:                     if ($env{'request.course.id'}) {
 4681:                         my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 4682:                         my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
 4683:                         my $url = &hreflocation('',$fullpath);
 4684:                         if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
 4685:                             my $relpath = $1;
 4686:                             if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
 4687:                                 &add_filetype($allfiles,$1,'src');
 4688:                             }
 4689:                         }
 4690:                     }
 4691:                 }
 4692:             }
 4693:             if ($t->[4] =~ m{/>$}) {
 4694:                 pop(@state);
 4695:             }
 4696: 	} elsif ($t->[0] eq 'E') {
 4697: 	    my ($tagname) = ($t->[1]);
 4698: 	    if ($javafiles{'codebase'} ne '') {
 4699: 		$javafiles{'codebase'} .= '/';
 4700: 	    }  
 4701: 	    if (lc($tagname) eq 'applet' ||
 4702: 		lc($tagname) eq 'object' ||
 4703: 		(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
 4704: 		) {
 4705: 		foreach my $item (keys(%javafiles)) {
 4706: 		    if ($item ne 'codebase' && $javafiles{$item} ne '') {
 4707: 			my $file=$javafiles{'codebase'}.$javafiles{$item};
 4708: 			&add_filetype($allfiles,$file,$item);
 4709: 		    }
 4710: 		}
 4711: 	    } 
 4712: 	    pop @state;
 4713: 	}
 4714:     }
 4715:     foreach my $id (sort(keys(%flashvars))) {
 4716:         if ($shockwave{$id} ne '') {
 4717:             my @pairs = split(/\&/,$flashvars{$id});
 4718:             foreach my $pair (@pairs) {
 4719:                 my ($key,$value) = split(/\=/,$pair);
 4720:                 if ($key eq 'thumb') {
 4721:                     &add_filetype($allfiles,$value,$key);
 4722:                 } elsif ($key eq 'content') {
 4723:                     my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
 4724:                     my ($ext) = ($value =~ /\.([^.]+)$/);
 4725:                     if ($ext ne '') {
 4726:                         &add_filetype($allfiles,$path.$value,$ext);
 4727:                     }
 4728:                 }
 4729:             }
 4730:         }
 4731:     }
 4732:     return 'ok';
 4733: }
 4734: 
 4735: sub add_filetype {
 4736:     my ($allfiles,$file,$type)=@_;
 4737:     if (exists($allfiles->{$file})) {
 4738: 	unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
 4739: 	    push(@{$allfiles->{$file}}, &escape($type));
 4740: 	}
 4741:     } else {
 4742: 	@{$allfiles->{$file}} = (&escape($type));
 4743:     }
 4744: }
 4745: 
 4746: sub embedded_dependency {
 4747:     my ($allfiles,$related,$identifier,$pathfrom) = @_;
 4748:     if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
 4749:         if (($identifier ne '') &&
 4750:             (ref($related->{$identifier}) eq 'ARRAY') &&
 4751:             ($pathfrom ne '')) {
 4752:             my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
 4753:             foreach my $dep (@{$related->{$identifier}}) {
 4754:                 &add_filetype($allfiles,$path.$dep,'object');
 4755:             }
 4756:         }
 4757:     }
 4758:     return;
 4759: }
 4760: 
 4761: sub check_dimensions {
 4762:     my ($inputfile) = @_;
 4763:     my ($fullwidth,$fullheight);
 4764:     if (($inputfile =~ m|^[/\w.\-]+$|) && (-e $inputfile)) {
 4765:         my $mm = new File::MMagic;
 4766:         my $mime_type = $mm->checktype_filename($inputfile);
 4767:         if ($mime_type =~ m{^image/}) {
 4768:             if (open(PIPE,"identify $inputfile 2>&1 |")) {
 4769:                 my $imageinfo = <PIPE>;
 4770:                 if (!close(PIPE)) {
 4771:                     &Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile");
 4772:                 }
 4773:                 chomp($imageinfo);
 4774:                 my ($fullsize) =
 4775:                     ($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/);
 4776:                 if ($fullsize) {
 4777:                     ($fullwidth,$fullheight) = split(/x/,$fullsize);
 4778:                 }
 4779:             }
 4780:         }
 4781:     }
 4782:     return ($fullwidth,$fullheight);
 4783: }
 4784: 
 4785: sub bubblesheet_converter {
 4786:     my ($cdom,$fullpath,$config,$format) = @_;
 4787:     if ((&domain($cdom) ne '') &&
 4788:         ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
 4789:         (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
 4790:         my (%csvcols,%csvoptions);
 4791:         if (ref($config->{'fields'}) eq 'HASH') {  
 4792:             %csvcols = %{$config->{'fields'}};
 4793:         }
 4794:         if (ref($config->{'options'}) eq 'HASH') {
 4795:             %csvoptions = %{$config->{'options'}};
 4796:         }
 4797:         my %csvbynum = reverse(%csvcols);
 4798:         my %scantronconf = &get_scantron_config($format,$cdom);
 4799:         if (keys(%scantronconf)) {
 4800:             my %bynum = (
 4801:                           $scantronconf{CODEstart} => 'CODEstart',
 4802:                           $scantronconf{IDstart}   => 'IDstart',
 4803:                           $scantronconf{PaperID}   => 'PaperID',
 4804:                           $scantronconf{FirstName} => 'FirstName',
 4805:                           $scantronconf{LastName}  => 'LastName',
 4806:                           $scantronconf{Qstart}    => 'Qstart',
 4807:                         );
 4808:             my @ordered;
 4809:             foreach my $item (sort { $a <=> $b } keys(%bynum)) {
 4810:                 push(@ordered,$bynum{$item});
 4811:             }
 4812:             my %mapstart = (
 4813:                               CODEstart => 'CODE',
 4814:                               IDstart   => 'ID',
 4815:                               PaperID   => 'PaperID',
 4816:                               FirstName => 'FirstName',
 4817:                               LastName  => 'LastName',
 4818:                               Qstart    => 'FirstQuestion',
 4819:                            );
 4820:             my %maplength = (
 4821:                               CODEstart => 'CODElength',
 4822:                               IDstart   => 'IDlength',
 4823:                               PaperID   => 'PaperIDlength',
 4824:                               FirstName => 'FirstNamelength',
 4825:                               LastName  => 'LastNamelength',
 4826:             );
 4827:             if (open(my $fh,'<',$fullpath)) {
 4828:                 my $output;
 4829:                 my %lettdig = &letter_to_digits();
 4830:                 my %diglett = reverse(%lettdig);
 4831:                 my $numletts = scalar(keys(%lettdig));
 4832:                 my $num = 0;
 4833:                 while (my $line=<$fh>) {
 4834:                     $num ++;
 4835:                     next if (($num == 1) && ($csvoptions{'hdr'} == 1));
 4836:                     $line =~ s{[\r\n]+$}{};
 4837:                     my %found;
 4838:                     my @values = split(/,/,$line,-1);
 4839:                     my ($qstart,$record);
 4840:                     for (my $i=0; $i<@values; $i++) {
 4841:                         if ((($qstart ne '') && ($i > $qstart)) ||
 4842:                             ($csvbynum{$i} eq 'FirstQuestion')) {
 4843:                             if ($values[$i] eq '') {
 4844:                                 $values[$i] = $scantronconf{'Qoff'};
 4845:                             } elsif ($scantronconf{'Qon'} eq 'number') {
 4846:                                 if ($values[$i] =~ /^[A-Ja-j]$/) {
 4847:                                     $values[$i] = $lettdig{uc($values[$i])};
 4848:                                 }
 4849:                             } elsif ($scantronconf{'Qon'} eq 'letter') {
 4850:                                 if ($values[$i] =~ /^[0-9]$/) {
 4851:                                     $values[$i] = $diglett{$values[$i]};
 4852:                                 }
 4853:                             } else {
 4854:                                 if ($values[$i] =~ /^[0-9A-Ja-j]$/) {
 4855:                                     my $digit;
 4856:                                     if ($values[$i] =~ /^[A-Ja-j]$/) {
 4857:                                         $digit = $lettdig{uc($values[$i])}-1;
 4858:                                         if ($values[$i] eq 'J') {
 4859:                                             $digit += $numletts;
 4860:                                         }
 4861:                                     } elsif ($values[$i] =~ /^[0-9]$/) {
 4862:                                         $digit = $values[$i]-1;
 4863:                                         if ($values[$i] eq '0') {
 4864:                                             $digit += $numletts;
 4865:                                         }
 4866:                                     }
 4867:                                     my $qval='';
 4868:                                     for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) {
 4869:                                         if ($j == $digit) {
 4870:                                             $qval .= $scantronconf{'Qon'};
 4871:                                         } else {
 4872:                                             $qval .= $scantronconf{'Qoff'};
 4873:                                         }
 4874:                                     }
 4875:                                     $values[$i] = $qval;
 4876:                                 }
 4877:                             }
 4878:                             if (length($values[$i]) > $scantronconf{'Qlength'}) {
 4879:                                 $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'});
 4880:                             }
 4881:                             my $numblank = $scantronconf{'Qlength'} - length($values[$i]);
 4882:                             if ($numblank > 0) {
 4883:                                  $values[$i] .= ($scantronconf{'Qoff'} x $numblank);
 4884:                             }
 4885:                             if ($csvbynum{$i} eq 'FirstQuestion') {
 4886:                                 $qstart = $i;
 4887:                                 $found{$csvbynum{$i}} = $values[$i];
 4888:                             } else {
 4889:                                 $found{'FirstQuestion'} .= $values[$i];
 4890:                             }
 4891:                         } elsif (exists($csvbynum{$i})) {
 4892:                             if ($csvoptions{'rem'}) {
 4893:                                 $values[$i] =~ s/^\s+//;
 4894:                             }
 4895:                             if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) {
 4896:                                 while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {
 4897:                                     $values[$i] = '0'.$values[$i];
 4898:                                 }
 4899:                             }
 4900:                             $found{$csvbynum{$i}} = $values[$i];
 4901:                         }
 4902:                     }
 4903:                     foreach my $item (@ordered) {
 4904:                         my $currlength = 1+length($record);
 4905:                         my $numspaces = $scantronconf{$item} - $currlength;
 4906:                         if ($numspaces > 0) {
 4907:                             $record .= (' ' x $numspaces);
 4908:                         }
 4909:                         if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) {
 4910:                             unless ($item eq 'Qstart') {
 4911:                                 if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) {
 4912:                                     $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}});
 4913:                                 }
 4914:                             }
 4915:                             $record .= $found{$mapstart{$item}};
 4916:                         }
 4917:                     }
 4918:                     $output .= "$record\n";
 4919:                 }
 4920:                 close($fh);
 4921:                 if ($output) {
 4922:                     if (open(my $fh,'>',$fullpath)) {
 4923:                         print $fh $output;
 4924:                         close($fh);
 4925:                     }
 4926:                 }
 4927:             }
 4928:         }
 4929:         return;
 4930:     }
 4931: }
 4932: 
 4933: sub letter_to_digits {
 4934:     my %lettdig = (
 4935:                     A => 1,
 4936:                     B => 2,
 4937:                     C => 3,
 4938:                     D => 4,
 4939:                     E => 5,
 4940:                     F => 6,
 4941:                     G => 7,
 4942:                     H => 8,
 4943:                     I => 9,
 4944:                     J => 0,
 4945:                   );
 4946:     return %lettdig;
 4947: }
 4948: 
 4949: sub get_scantron_config {
 4950:     my ($which,$cdom) = @_;
 4951:     my @lines = &get_scantronformat_file($cdom);
 4952:     my %config;
 4953:     #FIXME probably should move to XML it has already gotten a bit much now
 4954:     foreach my $line (@lines) {
 4955:         my ($name,$descrip)=split(/:/,$line);
 4956:         if ($name ne $which ) { next; }
 4957:         chomp($line);
 4958:         my @config=split(/:/,$line);
 4959:         $config{'name'}=$config[0];
 4960:         $config{'description'}=$config[1];
 4961:         $config{'CODElocation'}=$config[2];
 4962:         $config{'CODEstart'}=$config[3];
 4963:         $config{'CODElength'}=$config[4];
 4964:         $config{'IDstart'}=$config[5];
 4965:         $config{'IDlength'}=$config[6];
 4966:         $config{'Qstart'}=$config[7];
 4967:         $config{'Qlength'}=$config[8];
 4968:         $config{'Qoff'}=$config[9];
 4969:         $config{'Qon'}=$config[10];
 4970:         $config{'PaperID'}=$config[11];
 4971:         $config{'PaperIDlength'}=$config[12];
 4972:         $config{'FirstName'}=$config[13];
 4973:         $config{'FirstNamelength'}=$config[14];
 4974:         $config{'LastName'}=$config[15];
 4975:         $config{'LastNamelength'}=$config[16];
 4976:         $config{'BubblesPerRow'}=$config[17];
 4977:         last;
 4978:     }
 4979:     return %config;
 4980: }
 4981: 
 4982: sub get_scantronformat_file {
 4983:     my ($cdom) = @_;
 4984:     if ($cdom eq '') {
 4985:         $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'};
 4986:     }
 4987:     my %domconfig = &get_dom('configuration',['scantron'],$cdom);
 4988:     my $gottab = 0;
 4989:     my @lines;
 4990:     if (ref($domconfig{'scantron'}) eq 'HASH') {
 4991:         if ($domconfig{'scantron'}{'scantronformat'} ne '') {
 4992:             my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'});
 4993:             if ($formatfile ne '-1') {
 4994:                 @lines = split("\n",$formatfile,-1);
 4995:                 $gottab = 1;
 4996:             }
 4997:         }
 4998:     }
 4999:     if (!$gottab) {
 5000:         my $confname = $cdom.'-domainconfig';
 5001:         my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab';
 5002:         my $formatfile = &getfile($default);
 5003:         if ($formatfile ne '-1') {
 5004:             @lines = split("\n",$formatfile,-1);
 5005:             $gottab = 1;
 5006:         }
 5007:     }
 5008:     if (!$gottab) {
 5009:         my @domains = &current_machine_domains();
 5010:         if (grep(/^\Q$cdom\E$/,@domains)) {
 5011:             if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {
 5012:                 @lines = <$fh>;
 5013:                 close($fh);
 5014:             }
 5015:         } else {
 5016:             if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {
 5017:                 @lines = <$fh>;
 5018:                 close($fh);
 5019:             }
 5020:         }
 5021:         chomp(@lines);
 5022:     }
 5023:     return @lines;
 5024: }
 5025: 
 5026: sub removeuploadedurl {
 5027:     my ($url)=@_;	
 5028:     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
 5029:     return &removeuserfile($uname,$udom,$fname);
 5030: }
 5031: 
 5032: sub removeuserfile {
 5033:     my ($docuname,$docudom,$fname)=@_;
 5034:     my $home=&homeserver($docuname,$docudom);    
 5035:     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
 5036:     if ($result eq 'ok') {	
 5037:         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
 5038:             my $metafile = $fname.'.meta';
 5039:             my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
 5040: 	    my $url = "/uploaded/$docudom/$docuname/$fname";
 5041:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];	   
 5042:             my $sqlresult = 
 5043:                 &update_portfolio_table($docuname,$docudom,$file,
 5044:                                         'portfolio_metadata',$group,
 5045:                                         'delete');
 5046:         }
 5047:     }
 5048:     return $result;
 5049: }
 5050: 
 5051: sub mkdiruserfile {
 5052:     my ($docuname,$docudom,$dir)=@_;
 5053:     my $home=&homeserver($docuname,$docudom);
 5054:     return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
 5055: }
 5056: 
 5057: sub renameuserfile {
 5058:     my ($docuname,$docudom,$old,$new)=@_;
 5059:     my $home=&homeserver($docuname,$docudom);
 5060:     my $result = &reply("renameuserfile:$docudom:$docuname:".
 5061:                         &escape("$old").':'.&escape("$new"),$home);
 5062:     if ($result eq 'ok') {
 5063:         if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
 5064:             my $oldmeta = $old.'.meta';
 5065:             my $newmeta = $new.'.meta';
 5066:             my $metaresult = 
 5067:                 &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
 5068: 	    my $url = "/uploaded/$docudom/$docuname/$old";
 5069:             my ($file,$group) = (&parse_portfolio_url($url))[3,4];
 5070:             my $sqlresult = 
 5071:                 &update_portfolio_table($docuname,$docudom,$file,
 5072:                                         'portfolio_metadata',$group,
 5073:                                         'delete');
 5074:         }
 5075:     }
 5076:     return $result;
 5077: }
 5078: 
 5079: # ------------------------------------------------------------------------- Log
 5080: 
 5081: sub log {
 5082:     my ($dom,$nam,$hom,$what)=@_;
 5083:     return critical("log:$dom:$nam:$what",$hom);
 5084: }
 5085: 
 5086: # ------------------------------------------------------------------ Course Log
 5087: #
 5088: # This routine flushes several buffers of non-mission-critical nature
 5089: #
 5090: 
 5091: sub flushcourselogs {
 5092:     &logthis('Flushing log buffers');
 5093: #
 5094: # course logs
 5095: # This is a log of all transactions in a course, which can be used
 5096: # for data mining purposes
 5097: #
 5098: # It also collects the courseid database, which lists last transaction
 5099: # times and course titles for all courseids
 5100: #
 5101:     my %courseidbuffer=();
 5102:     foreach my $crsid (keys(%courselogs)) {
 5103:         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
 5104: 		          &escape($courselogs{$crsid}),
 5105: 		          $coursehombuf{$crsid}) eq 'ok') {
 5106: 	    delete $courselogs{$crsid};
 5107:         } else {
 5108:             &logthis('Failed to flush log buffer for '.$crsid);
 5109:             if (length($courselogs{$crsid})>40000) {
 5110:                &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
 5111:                         " exceeded maximum size, deleting.</font>");
 5112:                delete $courselogs{$crsid};
 5113:             }
 5114:         }
 5115:         $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
 5116:             'description' => $coursedescrbuf{$crsid},
 5117:             'inst_code'    => $courseinstcodebuf{$crsid},
 5118:             'type'        => $coursetypebuf{$crsid},
 5119:             'owner'       => $courseownerbuf{$crsid},
 5120:         };
 5121:     }
 5122: #
 5123: # Write course id database (reverse lookup) to homeserver of courses 
 5124: # Is used in pickcourse
 5125: #
 5126:     foreach my $crs_home (keys(%courseidbuffer)) {
 5127:         my $response = &courseidput(&host_domain($crs_home),
 5128:                                     $courseidbuffer{$crs_home},
 5129:                                     $crs_home,'timeonly');
 5130:     }
 5131: #
 5132: # File accesses
 5133: # Writes to the dynamic metadata of resources to get hit counts, etc.
 5134: #
 5135:     foreach my $entry (keys(%accesshash)) {
 5136:         if ($entry =~ /___count$/) {
 5137:             my ($dom,$name);
 5138:             ($dom,$name,undef)=
 5139: 		($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
 5140:             if (! defined($dom) || $dom eq '' || 
 5141:                 ! defined($name) || $name eq '') {
 5142:                 my $cid = $env{'request.course.id'};
 5143: #
 5144: # FIXME 11/29/2021
 5145: # Typo in rev. 1.458 (2003/12/09)??
 5146: # These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
 5147: #
 5148: # While these ramain as  $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
 5149: # $dom and $name will always be null, so the &inc() call will default to storing this data
 5150: # in a nohist_accesscount.db file for the user rather than the course.
 5151: #
 5152: # That said there is a lot of noise in the data being stored.
 5153: # So counts for prtspool/  and adm/ etc. are recorded.
 5154: #
 5155: # A review of which items ending '___count' are written to %accesshash should likely be 
 5156: # made before deciding whether to set these to 'course.' instead of 'request.'
 5157: #
 5158: # Under the current scheme each user receives a nohist_accesscount.db file listing 
 5159: # accesses for things which are not published resources, regardless of course, and
 5160: # there is not a nohist_accesscount.db file in a course, which might log accesses from
 5161: # anyone in the course for things which are not published resources.
 5162: #
 5163: # For an author, nohist_accesscount.db ends up having records for other items
 5164: # mixed up with the legitimate access counts for the author's published resources.
 5165: #
 5166:                 $dom  = $env{'request.'.$cid.'.domain'};
 5167:                 $name = $env{'request.'.$cid.'.num'};
 5168:             }
 5169:             my $value = $accesshash{$entry};
 5170:             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
 5171:             my %temphash=($url => $value);
 5172:             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
 5173:             if ($result eq 'ok') {
 5174:                 delete $accesshash{$entry};
 5175:             }
 5176:         } else {
 5177:             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
 5178:             if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
 5179:             my %temphash=($entry => $accesshash{$entry});
 5180:             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
 5181:                 delete $accesshash{$entry};
 5182:             }
 5183:         }
 5184:     }
 5185: #
 5186: # Roles
 5187: # Reverse lookup of user roles for course faculty/staff and co-authorship
 5188: #
 5189:     foreach my $entry (keys(%userrolehash)) {
 5190:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=
 5191: 	    split(/\:/,$entry);
 5192:         if (&put('nohist_userroles',
 5193:              { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
 5194:                 $rudom,$runame) eq 'ok') {
 5195: 	    delete $userrolehash{$entry};
 5196:         }
 5197:     }
 5198: #
 5199: # Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au)
 5200: #
 5201:     my %domrolebuffer = ();
 5202:     foreach my $entry (keys(%domainrolehash)) {
 5203:         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
 5204:         if ($domrolebuffer{$rudom}) {
 5205:             $domrolebuffer{$rudom}.='&'.&escape($entry).
 5206:                       '='.&escape($domainrolehash{$entry});
 5207:         } else {
 5208:             $domrolebuffer{$rudom}.=&escape($entry).
 5209:                       '='.&escape($domainrolehash{$entry});
 5210:         }
 5211:         delete $domainrolehash{$entry};
 5212:     }
 5213:     foreach my $dom (keys(%domrolebuffer)) {
 5214: 	my %servers;
 5215: 	if (defined(&domain($dom,'primary'))) {
 5216: 	    my $primary=&domain($dom,'primary');
 5217: 	    my $hostname=&hostname($primary);
 5218: 	    $servers{$primary} = $hostname;
 5219: 	} else { 
 5220: 	    %servers = &get_servers($dom,'library');
 5221: 	}
 5222: 	foreach my $tryserver (keys(%servers)) {
 5223: 	    if (&reply('domroleput:'.$dom.':'.
 5224: 		       $domrolebuffer{$dom},$tryserver) eq 'ok') {
 5225: 		last;
 5226: 	    } else {  
 5227: 		&logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
 5228: 	    }
 5229:         }
 5230:     }
 5231:     $dumpcount++;
 5232: }
 5233: 
 5234: sub courselog {
 5235:     my $what=shift;
 5236:     $what=time.':'.$what;
 5237:     unless ($env{'request.course.id'}) { return ''; }
 5238:     $coursedombuf{$env{'request.course.id'}}=
 5239:        $env{'course.'.$env{'request.course.id'}.'.domain'};
 5240:     $coursenumbuf{$env{'request.course.id'}}=
 5241:        $env{'course.'.$env{'request.course.id'}.'.num'};
 5242:     $coursehombuf{$env{'request.course.id'}}=
 5243:        $env{'course.'.$env{'request.course.id'}.'.home'};
 5244:     $coursedescrbuf{$env{'request.course.id'}}=
 5245:        $env{'course.'.$env{'request.course.id'}.'.description'};
 5246:     $courseinstcodebuf{$env{'request.course.id'}}=
 5247:        $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
 5248:     $courseownerbuf{$env{'request.course.id'}}=
 5249:        $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
 5250:     $coursetypebuf{$env{'request.course.id'}}=
 5251:        $env{'course.'.$env{'request.course.id'}.'.type'};
 5252:     if (defined $courselogs{$env{'request.course.id'}}) {
 5253: 	$courselogs{$env{'request.course.id'}}.='&'.$what;
 5254:     } else {
 5255: 	$courselogs{$env{'request.course.id'}}.=$what;
 5256:     }
 5257:     if (length($courselogs{$env{'request.course.id'}})>4048) {
 5258: 	&flushcourselogs();
 5259:     }
 5260: }
 5261: 
 5262: sub courseacclog {
 5263:     my $fnsymb=shift;
 5264:     unless ($env{'request.course.id'}) { return ''; }
 5265:     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
 5266:     if ($fnsymb=~/$LONCAPA::assess_re/) {
 5267:         $what.=':POST';
 5268:         # FIXME: Probably ought to escape things....
 5269: 	foreach my $key (keys(%env)) {
 5270:             if ($key=~/^form\.(.*)/) {
 5271:                 my $formitem = $1;
 5272:                 if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
 5273:                     $what.=':'.$formitem.'='.$env{$key};
 5274:                 } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
 5275:                     if ($formitem eq 'proctorpassword') {
 5276:                         $what.=':'.$formitem.'=' . '*' x length($env{$key});
 5277:                     } else {
 5278:                         $what.=':'.$formitem.'='.$env{$key};
 5279:                     }
 5280:                 }
 5281:             }
 5282:         }
 5283:     } elsif ($fnsymb =~ m:^/adm/searchcat:) {
 5284:         # FIXME: We should not be depending on a form parameter that someone
 5285:         # editing lonsearchcat.pm might change in the future.
 5286:         if ($env{'form.phase'} eq 'course_search') {
 5287:             $what.= ':POST';
 5288:             # FIXME: Probably ought to escape things....
 5289:             foreach my $element ('courseexp','crsfulltext','crsrelated',
 5290:                                  'crsdiscuss') {
 5291:                 $what.=':'.$element.'='.$env{'form.'.$element};
 5292:             }
 5293:         }
 5294:     }
 5295:     &courselog($what);
 5296: }
 5297: 
 5298: sub countacc {
 5299:     my $url=&declutter(shift);
 5300:     return if (! defined($url) || $url eq '');
 5301:     unless ($env{'request.course.id'}) { return ''; }
 5302: #
 5303: # Mark that this url was used in this course
 5304: #
 5305:     $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
 5306: #
 5307: # Increase the access count for this resource in this child process
 5308: #
 5309:     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
 5310:     $accesshash{$key}++;
 5311: }
 5312: 
 5313: sub linklog {
 5314:     my ($from,$to)=@_;
 5315:     $from=&declutter($from);
 5316:     $to=&declutter($to);
 5317:     $accesshash{$from.'___'.$to.'___comefrom'}=1;
 5318:     $accesshash{$to.'___'.$from.'___goto'}=1;
 5319: }
 5320: 
 5321: sub statslog {
 5322:     my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
 5323:     if ($users<2) { return; }
 5324:     my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
 5325:             'course'       => $env{'request.course.id'},
 5326:             'sections'     => '"all"',
 5327:             'num_students' => $users,
 5328:             'part'         => $part,
 5329:             'symb'         => $symb,
 5330:             'mean_tries'   => $av_attempts,
 5331:             'deg_of_diff'  => $degdiff});
 5332:     foreach my $key (keys(%dynstore)) {
 5333:         $accesshash{$key}=$dynstore{$key};
 5334:     }
 5335: }
 5336:   
 5337: sub userrolelog {
 5338:     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
 5339:     if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
 5340:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
 5341:        $userrolehash
 5342:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
 5343:                     =$tend.':'.$tstart;
 5344:     }
 5345:     if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
 5346:        $userrolehash
 5347:          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
 5348:                     =$tend.':'.$tstart;
 5349:     }
 5350:     if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) {
 5351:        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
 5352:        $domainrolehash
 5353:          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
 5354:                     = $tend.':'.$tstart;
 5355:     }
 5356: }
 5357: 
 5358: sub courserolelog {
 5359:     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
 5360:     if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
 5361:         my $cdom = $1;
 5362:         my $cnum = $2;
 5363:         my $sec = $3;
 5364:         my $namespace = 'rolelog';
 5365:         my %storehash = (
 5366:                            role    => $trole,
 5367:                            start   => $tstart,
 5368:                            end     => $tend,
 5369:                            selfenroll => $selfenroll,
 5370:                            context    => $context,
 5371:                         );
 5372:         if ($trole eq 'gr') {
 5373:             $namespace = 'groupslog';
 5374:             $storehash{'group'} = $sec;
 5375:         } else {
 5376:             $storehash{'section'} = $sec;
 5377:         }
 5378:         &write_log('course',$namespace,\%storehash,$delflag,$username,
 5379:                    $domain,$cnum,$cdom);
 5380:         if (($trole ne 'st') || ($sec ne '')) {
 5381:             &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
 5382:         }
 5383:     }
 5384:     return;
 5385: }
 5386: 
 5387: sub domainrolelog {
 5388:     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
 5389:     if ($area =~ m{^/($match_domain)/$}) {
 5390:         my $cdom = $1;
 5391:         my $domconfiguser = &get_domainconfiguser($cdom);
 5392:         my $namespace = 'rolelog';
 5393:         my %storehash = (
 5394:                            role    => $trole,
 5395:                            start   => $tstart,
 5396:                            end     => $tend,
 5397:                            context => $context,
 5398:                         );
 5399:         &write_log('domain',$namespace,\%storehash,$delflag,$username,
 5400:                    $domain,$domconfiguser,$cdom);
 5401:     }
 5402:     return;
 5403: 
 5404: }
 5405: 
 5406: sub coauthorrolelog {
 5407:     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
 5408:     if ($area =~ m{^/($match_domain)/($match_username)$}) {
 5409:         my $audom = $1;
 5410:         my $auname = $2;
 5411:         my $namespace = 'rolelog';
 5412:         my %storehash = (
 5413:                            role    => $trole,
 5414:                            start   => $tstart,
 5415:                            end     => $tend,
 5416:                            context => $context,
 5417:                         );
 5418:         &write_log('author',$namespace,\%storehash,$delflag,$username,
 5419:                    $domain,$auname,$audom);
 5420:     }
 5421:     return;
 5422: }
 5423: 
 5424: sub get_course_adv_roles {
 5425:     my ($cid,$codes) = @_;
 5426:     $cid=$env{'request.course.id'} unless (defined($cid));
 5427:     my %coursehash=&coursedescription($cid);
 5428:     my $crstype = &Apache::loncommon::course_type($cid);
 5429:     my %nothide=();
 5430:     foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
 5431:         if ($user !~ /:/) {
 5432: 	    $nothide{join(':',split(/[\@]/,$user))}=1;
 5433:         } else {
 5434:             $nothide{$user}=1;
 5435:         }
 5436:     }
 5437:     my @possdoms = ($coursehash{'domain'});
 5438:     if ($coursehash{'checkforpriv'}) {
 5439:         push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
 5440:     }
 5441:     my %returnhash=();
 5442:     my %dumphash=
 5443:             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
 5444:     my $now=time;
 5445:     my %privileged;
 5446:     foreach my $entry (keys(%dumphash)) {
 5447: 	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
 5448:         if (($tstart) && ($tstart<0)) { next; }
 5449:         if (($tend) && ($tend<$now)) { next; }
 5450:         if (($tstart) && ($now<$tstart)) { next; }
 5451:         my ($role,$username,$domain,$section)=split(/\:/,$entry);
 5452: 	if ($username eq '' || $domain eq '') { next; }
 5453:         if ((&privileged($username,$domain,\@possdoms)) &&
 5454:             (!$nothide{$username.':'.$domain})) { next; }
 5455: 	if ($role eq 'cr') { next; }
 5456:         if ($codes) {
 5457:             if ($section) { $role .= ':'.$section; }
 5458:             if ($returnhash{$role}) {
 5459:                 $returnhash{$role}.=','.$username.':'.$domain;
 5460:             } else {
 5461:                 $returnhash{$role}=$username.':'.$domain;
 5462:             }
 5463:         } else {
 5464:             my $key=&plaintext($role,$crstype);
 5465:             if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
 5466:             if ($returnhash{$key}) {
 5467: 	        $returnhash{$key}.=','.$username.':'.$domain;
 5468:             } else {
 5469:                 $returnhash{$key}=$username.':'.$domain;
 5470:             }
 5471:         }
 5472:     }
 5473:     return %returnhash;
 5474: }
 5475: 
 5476: sub get_my_roles {
 5477:     my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
 5478:     unless (defined($uname)) { $uname=$env{'user.name'}; }
 5479:     unless (defined($udom)) { $udom=$env{'user.domain'}; }
 5480:     my (%dumphash,%nothide);
 5481:     if ($context eq 'userroles') {
 5482:         %dumphash = &dump('roles',$udom,$uname);
 5483:     } else {
 5484:         %dumphash = &dump('nohist_userroles',$udom,$uname);
 5485:         if ($hidepriv) {
 5486:             my %coursehash=&coursedescription($udom.'_'.$uname);
 5487:             foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
 5488:                 if ($user !~ /:/) {
 5489:                     $nothide{join(':',split(/[\@]/,$user))} = 1;
 5490:                 } else {
 5491:                     $nothide{$user} = 1;
 5492:                 }
 5493:             }
 5494:         }
 5495:     }
 5496:     my %returnhash=();
 5497:     my $now=time;
 5498:     my %privileged;
 5499:     foreach my $entry (keys(%dumphash)) {
 5500:         my ($role,$tend,$tstart);
 5501:         if ($context eq 'userroles') {
 5502:             next if ($entry =~ /^rolesdef/);
 5503: 	    ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
 5504:         } else {
 5505:             ($tend,$tstart)=split(/\:/,$dumphash{$entry});
 5506:         }
 5507:         if (($tstart) && ($tstart<0)) { next; }
 5508:         my $status = 'active';
 5509:         if (($tend) && ($tend<=$now)) {
 5510:             $status = 'previous';
 5511:         } 
 5512:         if (($tstart) && ($now<$tstart)) {
 5513:             $status = 'future';
 5514:         }
 5515:         if (ref($types) eq 'ARRAY') {
 5516:             if (!grep(/^\Q$status\E$/,@{$types})) {
 5517:                 next;
 5518:             } 
 5519:         } else {
 5520:             if ($status ne 'active') {
 5521:                 next;
 5522:             }
 5523:         }
 5524:         my ($rolecode,$username,$domain,$section,$area);
 5525:         if ($context eq 'userroles') {
 5526:             ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);
 5527:             (undef,$domain,$username,$section) = split(/\//,$area);
 5528:         } else {
 5529:             ($role,$username,$domain,$section) = split(/\:/,$entry);
 5530:         }
 5531:         if (ref($roledoms) eq 'ARRAY') {
 5532:             if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
 5533:                 next;
 5534:             }
 5535:         }
 5536:         if (ref($roles) eq 'ARRAY') {
 5537:             if (!grep(/^\Q$role\E$/,@{$roles})) {
 5538:                 if ($role =~ /^cr\//) {
 5539:                     if (!grep(/^cr$/,@{$roles})) {
 5540:                         next;
 5541:                     }
 5542:                 } elsif ($role =~ /^gr\//) {
 5543:                     if (!grep(/^gr$/,@{$roles})) {
 5544:                         next;
 5545:                     }
 5546:                 } else {
 5547:                     next;
 5548:                 }
 5549:             }
 5550:         }
 5551:         if ($hidepriv) {
 5552:             my @privroles = ('dc','su');
 5553:             if ($context eq 'userroles') {
 5554:                 next if (grep(/^\Q$role\E$/,@privroles));
 5555:             } else {
 5556:                 my $possdoms = [$domain];
 5557:                 if (ref($roledoms) eq 'ARRAY') {
 5558:                    push(@{$possdoms},@{$roledoms}); 
 5559:                 }
 5560:                 if (&privileged($username,$domain,$possdoms,\@privroles)) {
 5561:                     if (!$nothide{$username.':'.$domain}) {
 5562:                         next;
 5563:                     }
 5564:                 }
 5565:             }
 5566:         }
 5567:         if ($withsec) {
 5568:             $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
 5569:                 $tstart.':'.$tend;
 5570:         } else {
 5571:             $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
 5572:         }
 5573:     }
 5574:     return %returnhash;
 5575: }
 5576: 
 5577: sub get_all_adhocroles {
 5578:     my ($dom) = @_;
 5579:     my @roles_by_num = ();
 5580:     my %domdefaults = &get_domain_defaults($dom);
 5581:     my (%description,%access_in_dom,%access_info);
 5582:     if (ref($domdefaults{'adhocroles'}) eq 'HASH') {
 5583:         my $count = 0;
 5584:         my %domcurrent = %{$domdefaults{'adhocroles'}};
 5585:         my %ordered;
 5586:         foreach my $role (sort(keys(%domcurrent))) {
 5587:             my ($order,$desc,$access_in_dom);
 5588:             if (ref($domcurrent{$role}) eq 'HASH') {
 5589:                 $order = $domcurrent{$role}{'order'};
 5590:                 $desc = $domcurrent{$role}{'desc'};
 5591:                 $access_in_dom{$role} = $domcurrent{$role}{'access'};
 5592:                 $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}};
 5593:             }
 5594:             if ($order eq '') {
 5595:                 $order = $count;
 5596:             }
 5597:             $ordered{$order} = $role;
 5598:             if ($desc ne '') {
 5599:                 $description{$role} = $desc;
 5600:             } else {
 5601:                 $description{$role}= $role;
 5602:             }
 5603:             $count++;
 5604:         }
 5605:         foreach my $item (sort {$a <=> $b } (keys(%ordered))) {
 5606:             push(@roles_by_num,$ordered{$item});
 5607:         }
 5608:     }
 5609:     return (\@roles_by_num,\%description,\%access_in_dom,\%access_info);
 5610: }
 5611: 
 5612: sub get_my_adhocroles {
 5613:     my ($cid,$checkreg) = @_;
 5614:     my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num);
 5615:     if ($env{'request.course.id'} eq $cid) {
 5616:         $cdom = $env{'course.'.$cid.'.domain'};
 5617:         $cnum = $env{'course.'.$cid.'.num'};
 5618:         $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'};
 5619:     } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
 5620:         $cdom = $1;
 5621:         $cnum = $2;
 5622:         %info = &get('environment',['internal.coursecode'],
 5623:                      $cdom,$cnum);
 5624:     }
 5625:     if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
 5626:         my $user = $env{'user.name'}.':'.$env{'user.domain'};
 5627:         my %rosterhash = &get('classlist',[$user],$cdom,$cnum);
 5628:         if ($rosterhash{$user} ne '') {
 5629:             my $type = (split(/:/,$rosterhash{$user}))[5];
 5630:             return ([],{}) if ($type eq 'auto');
 5631:         }
 5632:     }
 5633:     if (($cdom ne '') && ($cnum ne ''))  {
 5634:         if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) {
 5635:             my $then=$env{'user.login.time'};
 5636:             my $update=$env{'user.update.time'};
 5637:             if (!$update) {
 5638:                 $update = $then;
 5639:             }
 5640:             my @liveroles;
 5641:             foreach my $role ('dh','da') {
 5642:                 if ($env{"user.role.$role./$cdom/"}) {
 5643:                     my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"});
 5644:                     my $limit = $update;
 5645:                     if ($env{'request.role'} eq "$role./$cdom/") {
 5646:                         $limit = $then;
 5647:                     }
 5648:                     my $activerole = 1;
 5649:                     if ($tstart && $tstart>$limit) { $activerole = 0; }
 5650:                     if ($tend   && $tend  <$limit) { $activerole = 0; }
 5651:                     if ($activerole) {
 5652:                         push(@liveroles,$role);
 5653:                     }
 5654:                 }
 5655:             }
 5656:             if (@liveroles) {
 5657:                 if (&homeserver($cnum,$cdom) ne 'no_host') {
 5658:                     my ($accessref,$accessinfo,%access_in_dom);
 5659:                     ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom);
 5660:                     if (ref($roles_by_num) eq 'ARRAY') {
 5661:                         if (@{$roles_by_num}) {
 5662:                             my %settings;
 5663:                             if ($env{'request.course.id'} eq $cid) {
 5664:                                 foreach my $envkey (keys(%env)) {
 5665:                                     if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) {
 5666:                                         $settings{$1} = $env{$envkey};
 5667:                                     }
 5668:                                 }
 5669:                             } else {
 5670:                                 %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc');
 5671:                             }
 5672:                             my %setincrs;
 5673:                             if ($settings{'internal.adhocaccess'}) {
 5674:                                 map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'});
 5675:                             }
 5676:                             my @statuses;
 5677:                             if ($env{'environment.inststatus'}) {
 5678:                                 @statuses = split(/,/,$env{'environment.inststatus'});
 5679:                             }
 5680:                             my $user = $env{'user.name'}.':'.$env{'user.domain'};
 5681:                             if (ref($accessref) eq 'HASH') {
 5682:                                 %access_in_dom = %{$accessref};
 5683:                             }
 5684:                             foreach my $role (@{$roles_by_num}) {
 5685:                                 my ($curraccess,@okstatus,@personnel);
 5686:                                 if ($setincrs{$role}) {
 5687:                                     ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role});
 5688:                                     if ($curraccess eq 'status') {
 5689:                                         @okstatus = split(/\&/,$rest);
 5690:                                     } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
 5691:                                         @personnel = split(/\&/,$rest);
 5692:                                     }
 5693:                                 } else {
 5694:                                     $curraccess = $access_in_dom{$role};
 5695:                                     if (ref($accessinfo) eq 'HASH') {
 5696:                                         if ($curraccess eq 'status') {
 5697:                                             if (ref($accessinfo->{$role}) eq 'ARRAY') {
 5698:                                                 @okstatus = @{$accessinfo->{$role}};
 5699:                                             }
 5700:                                         } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
 5701:                                             if (ref($accessinfo->{$role}) eq 'ARRAY') {
 5702:                                                 @personnel = @{$accessinfo->{$role}};
 5703:                                             }
 5704:                                         }
 5705:                                     }
 5706:                                 }
 5707:                                 if ($curraccess eq 'none') {
 5708:                                     next;
 5709:                                 } elsif ($curraccess eq 'all') {
 5710:                                     push(@possroles,$role);
 5711:                                 } elsif ($curraccess eq 'dh') {
 5712:                                     if (grep(/^dh$/,@liveroles)) {
 5713:                                         push(@possroles,$role);
 5714:                                     } else {
 5715:                                         next;
 5716:                                     }
 5717:                                 } elsif ($curraccess eq 'da') {
 5718:                                     if (grep(/^da$/,@liveroles)) {
 5719:                                         push(@possroles,$role);
 5720:                                     } else {
 5721:                                         next;
 5722:                                     }
 5723:                                 } elsif ($curraccess eq 'status') {
 5724:                                     if (@okstatus) {
 5725:                                         if (!@statuses) {
 5726:                                             if (grep(/^default$/,@okstatus)) {
 5727:                                                 push(@possroles,$role);
 5728:                                             }
 5729:                                         } else {
 5730:                                             foreach my $status (@okstatus) {
 5731:                                                 if (grep(/^\Q$status\E$/,@statuses)) {
 5732:                                                     push(@possroles,$role);
 5733:                                                     last;
 5734:                                                 }
 5735:                                             }
 5736:                                         }
 5737:                                     }
 5738:                                 } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
 5739:                                     if (grep(/^\Q$user\E$/,@personnel)) {
 5740:                                         if ($curraccess eq 'exc') {
 5741:                                             push(@possroles,$role);
 5742:                                         }
 5743:                                     } elsif ($curraccess eq 'inc') {
 5744:                                         push(@possroles,$role);
 5745:                                     }
 5746:                                 }
 5747:                             }
 5748:                         }
 5749:                     }
 5750:                 }
 5751:             }
 5752:         }
 5753:     }
 5754:     unless (ref($description) eq 'HASH') {
 5755:         if (ref($roles_by_num) eq 'ARRAY') {
 5756:             my %desc;
 5757:             map { $desc{$_} = $_; } (@{$roles_by_num});
 5758:             $description = \%desc;
 5759:         } else {
 5760:             $description = {};
 5761:         }
 5762:     }
 5763:     return (\@possroles,$description);
 5764: }
 5765: 
 5766: # ----------------------------------------------------- Frontpage Announcements
 5767: #
 5768: #
 5769: 
 5770: sub postannounce {
 5771:     my ($server,$text)=@_;
 5772:     unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
 5773:     unless ($text=~/\w/) { $text=''; }
 5774:     return &reply('setannounce:'.&escape($text),$server);
 5775: }
 5776: 
 5777: sub getannounce {
 5778: 
 5779:     if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) {
 5780: 	my $announcement='';
 5781: 	while (my $line = <$fh>) { $announcement .= $line; }
 5782: 	close($fh);
 5783: 	if ($announcement=~/\w/) { 
 5784: 	    return 
 5785:    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
 5786:    '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
 5787: 	} else {
 5788: 	    return '';
 5789: 	}
 5790:     } else {
 5791: 	return '';
 5792:     }
 5793: }
 5794: 
 5795: # ---------------------------------------------------------- Course ID routines
 5796: # Deal with domain's nohist_courseid.db files
 5797: #
 5798: 
 5799: sub courseidput {
 5800:     my ($domain,$storehash,$coursehome,$caller) = @_;
 5801:     return unless (ref($storehash) eq 'HASH');
 5802:     my $outcome;
 5803:     if ($caller eq 'timeonly') {
 5804:         my $cids = '';
 5805:         foreach my $item (keys(%$storehash)) {
 5806:             $cids.=&escape($item).'&';
 5807:         }
 5808:         $cids=~s/\&$//;
 5809:         $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
 5810:                           $coursehome);       
 5811:     } else {
 5812:         my $items = '';
 5813:         foreach my $item (keys(%$storehash)) {
 5814:             $items.= &escape($item).'='.
 5815:                      &freeze_escape($$storehash{$item}).'&';
 5816:         }
 5817:         $items=~s/\&$//;
 5818:         $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
 5819:                           $coursehome);
 5820:     }
 5821:     if ($outcome eq 'unknown_cmd') {
 5822:         my $what;
 5823:         foreach my $cid (keys(%$storehash)) {
 5824:             $what .= &escape($cid).'=';
 5825:             foreach my $item ('description','inst_code','owner','type') {
 5826:                 $what .= &escape($storehash->{$cid}{$item}).':';
 5827:             }
 5828:             $what =~ s/\:$/&/;
 5829:         }
 5830:         $what =~ s/\&$//;  
 5831:         return &reply('courseidput:'.$domain.':'.$what,$coursehome);
 5832:     } else {
 5833:         return $outcome;
 5834:     }
 5835: }
 5836: 
 5837: sub courseiddump {
 5838:     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
 5839:         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
 5840:         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
 5841:         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
 5842:         $hasuniquecode,$reqcrsdom,$reqinstcode)=@_;
 5843:     my $as_hash = 1;
 5844:     my %returnhash;
 5845:     if (!$domfilter) { $domfilter=''; }
 5846:     my %libserv = &all_library();
 5847:     foreach my $tryserver (keys(%libserv)) {
 5848:         if ( (  $hostidflag == 1 
 5849: 	        && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 
 5850: 	     || (!defined($hostidflag)) ) {
 5851: 
 5852: 	    if (($domfilter eq '') ||
 5853: 		(&host_domain($tryserver) eq $domfilter)) {
 5854:                 my $rep;
 5855:                 if (grep { $_ eq $tryserver } current_machine_ids()) {
 5856:                     $rep = LONCAPA::Lond::dump_course_id_handler(
 5857:                         join(":", (&host_domain($tryserver), $sincefilter, 
 5858:                                 &escape($descfilter), &escape($instcodefilter), 
 5859:                                 &escape($ownerfilter), &escape($coursefilter),
 5860:                                 &escape($typefilter), &escape($regexp_ok), 
 5861:                                 $as_hash, &escape($selfenrollonly), 
 5862:                                 &escape($catfilter), $showhidden, $caller, 
 5863:                                 &escape($cloner), &escape($cc_clone), $cloneonly, 
 5864:                                 &escape($createdbefore), &escape($createdafter), 
 5865:                                 &escape($creationcontext),$domcloner,$hasuniquecode,
 5866:                                 $reqcrsdom,&escape($reqinstcode))));
 5867:                 } else {
 5868:                     $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
 5869:                              $sincefilter.':'.&escape($descfilter).':'.
 5870:                              &escape($instcodefilter).':'.&escape($ownerfilter).
 5871:                              ':'.&escape($coursefilter).':'.&escape($typefilter).
 5872:                              ':'.&escape($regexp_ok).':'.$as_hash.':'.
 5873:                              &escape($selfenrollonly).':'.&escape($catfilter).':'.
 5874:                              $showhidden.':'.$caller.':'.&escape($cloner).':'.
 5875:                              &escape($cc_clone).':'.$cloneonly.':'.
 5876:                              &escape($createdbefore).':'.&escape($createdafter).':'.
 5877:                              &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.
 5878:                              ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
 5879:                 }
 5880:                      
 5881:                 my @pairs=split(/\&/,$rep);
 5882:                 foreach my $item (@pairs) {
 5883:                     my ($key,$value)=split(/\=/,$item,2);
 5884:                     $key = &unescape($key);
 5885:                     next if ($key =~ /^error: 2 /);
 5886:                     my $result = &thaw_unescape($value);
 5887:                     if (ref($result) eq 'HASH') {
 5888:                         $returnhash{$key}=$result;
 5889:                     } else {
 5890:                         my @responses = split(/:/,$value);
 5891:                         my @items = ('description','inst_code','owner','type');
 5892:                         for (my $i=0; $i<@responses; $i++) {
 5893:                             $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
 5894:                         }
 5895:                     }
 5896:                 }
 5897:             }
 5898:         }
 5899:     }
 5900:     return %returnhash;
 5901: }
 5902: 
 5903: sub courselastaccess {
 5904:     my ($cdom,$cnum,$hostidref) = @_;
 5905:     my %returnhash;
 5906:     if ($cdom && $cnum) {
 5907:         my $chome = &homeserver($cnum,$cdom);
 5908:         if ($chome ne 'no_host') {
 5909:             my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome);
 5910:             &extract_lastaccess(\%returnhash,$rep);
 5911:         }
 5912:     } else {
 5913:         if (!$cdom) { $cdom=''; }
 5914:         my %libserv = &all_library();
 5915:         foreach my $tryserver (keys(%libserv)) {
 5916:             if (ref($hostidref) eq 'ARRAY') {
 5917:                 next unless (grep(/^\Q$tryserver\E$/,@{$hostidref}));
 5918:             } 
 5919:             if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) {
 5920:                 my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver);
 5921:                 &extract_lastaccess(\%returnhash,$rep);
 5922:             }
 5923:         }
 5924:     }
 5925:     return %returnhash;
 5926: }
 5927: 
 5928: sub extract_lastaccess {
 5929:     my ($returnhash,$rep) = @_;
 5930:     if (ref($returnhash) eq 'HASH') {
 5931:         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || 
 5932:                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
 5933:                  $rep eq '') {
 5934:             my @pairs=split(/\&/,$rep);
 5935:             foreach my $item (@pairs) {
 5936:                 my ($key,$value)=split(/\=/,$item,2);
 5937:                 $key = &unescape($key);
 5938:                 next if ($key =~ /^error: 2 /);
 5939:                 $returnhash->{$key} = &thaw_unescape($value);
 5940:             }
 5941:         }
 5942:     }
 5943:     return;
 5944: }
 5945: 
 5946: # ---------------------------------------------------------- DC e-mail
 5947: 
 5948: sub dcmailput {
 5949:     my ($domain,$msgid,$message,$server)=@_;
 5950:     my $status = &critical(
 5951:        'dcmailput:'.$domain.':'.&escape($msgid).'='.
 5952:        &escape($message),$server);
 5953:     return $status;
 5954: }
 5955: 
 5956: sub dcmaildump {
 5957:     my ($dom,$startdate,$enddate,$senders) = @_;
 5958:     my %returnhash=();
 5959: 
 5960:     if (defined(&domain($dom,'primary'))) {
 5961:         my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
 5962:                                                          &escape($enddate).':';
 5963: 	my @esc_senders=map { &escape($_)} @$senders;
 5964: 	$cmd.=&escape(join('&',@esc_senders));
 5965: 	foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
 5966:             my ($key,$value) = split(/\=/,$line,2);
 5967:             if (($key) && ($value)) {
 5968:                 $returnhash{&unescape($key)} = &unescape($value);
 5969:             }
 5970:         }
 5971:     }
 5972:     return %returnhash;
 5973: }
 5974: # ---------------------------------------------------------- Domain roles
 5975: 
 5976: sub get_domain_roles {
 5977:     my ($dom,$roles,$startdate,$enddate)=@_;
 5978:     if ((!defined($startdate)) || ($startdate eq '')) {
 5979:         $startdate = '.';
 5980:     }
 5981:     if ((!defined($enddate)) || ($enddate eq '')) {
 5982:         $enddate = '.';
 5983:     }
 5984:     my $rolelist;
 5985:     if (ref($roles) eq 'ARRAY') {
 5986:         $rolelist = join('&',@{$roles});
 5987:     }
 5988:     my %personnel = ();
 5989: 
 5990:     my %servers = &get_servers($dom,'library');
 5991:     foreach my $tryserver (keys(%servers)) {
 5992: 	%{$personnel{$tryserver}}=();
 5993: 	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
 5994: 					    &escape($startdate).':'.
 5995: 					    &escape($enddate).':'.
 5996: 					    &escape($rolelist), $tryserver))) {
 5997: 	    my ($key,$value) = split(/\=/,$line,2);
 5998: 	    if (($key) && ($value)) {
 5999: 		$personnel{$tryserver}{&unescape($key)} = &unescape($value);
 6000: 	    }
 6001: 	}
 6002:     }
 6003:     return %personnel;
 6004: }
 6005: 
 6006: sub get_active_domroles {
 6007:     my ($dom,$roles) = @_;
 6008:     return () unless (ref($roles) eq 'ARRAY');
 6009:     my $now = time;
 6010:     my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now);
 6011:     my %domroles;
 6012:     foreach my $server (keys(%dompersonnel)) {
 6013:         foreach my $user (sort(keys(%{$dompersonnel{$server}}))) {
 6014:             my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user);
 6015:             $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user};
 6016:         }
 6017:     }
 6018:     return %domroles;
 6019: }
 6020: 
 6021: # ----------------------------------------------------------- Interval timing 
 6022: 
 6023: {
 6024: # Caches needed for speedup of navmaps
 6025: # We don't want to cache this for very long at all (5 seconds at most)
 6026: # 
 6027: # The user for whom we cache
 6028: my $cachedkey='';
 6029: # The cached times for this user
 6030: my %cachedtimes=();
 6031: # When this was last done
 6032: my $cachedtime='';
 6033: 
 6034: sub load_all_first_access {
 6035:     my ($uname,$udom,$ignorecache)=@_;
 6036:     if (($cachedkey eq $uname.':'.$udom) &&
 6037:         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
 6038:         (!$ignorecache)) {
 6039:         return;
 6040:     }
 6041:     $cachedtime=time;
 6042:     $cachedkey=$uname.':'.$udom;
 6043:     %cachedtimes=&dump('firstaccesstimes',$udom,$uname);
 6044: }
 6045: 
 6046: sub get_first_access {
 6047:     my ($type,$argsymb,$argmap,$ignorecache)=@_;
 6048:     my ($symb,$courseid,$udom,$uname)=&whichuser();
 6049:     if ($argsymb) { $symb=$argsymb; }
 6050:     my ($map,$id,$res)=&decode_symb($symb);
 6051:     if ($argmap) { $map = $argmap; }
 6052:     if ($type eq 'course') {
 6053: 	$res='course';
 6054:     } elsif ($type eq 'map') {
 6055: 	$res=&symbread($map);
 6056:     } else {
 6057: 	$res=$symb;
 6058:     }
 6059:     &load_all_first_access($uname,$udom,$ignorecache);
 6060:     return $cachedtimes{"$courseid\0$res"};
 6061: }
 6062: 
 6063: sub set_first_access {
 6064:     my ($type,$interval)=@_;
 6065:     my ($symb,$courseid,$udom,$uname)=&whichuser();
 6066:     my ($map,$id,$res)=&decode_symb($symb);
 6067:     if ($type eq 'course') {
 6068: 	$res='course';
 6069:     } elsif ($type eq 'map') {
 6070: 	$res=&symbread($map);
 6071:     } else {
 6072: 	$res=$symb;
 6073:     }
 6074:     $cachedkey='';
 6075:     my $firstaccess=&get_first_access($type,$symb,$map);
 6076:     if ($firstaccess) {
 6077:         &logthis("First access time already set ($firstaccess) when attempting ".
 6078:                  "to set new value (type: $type, extent: $res) for $uname:$udom ".
 6079:                  "in $courseid");
 6080:         return 'already_set';
 6081:     } else {
 6082:         my $start = time;
 6083: 	my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
 6084:                           $udom,$uname);
 6085:         if ($putres eq 'ok') {
 6086:             &put('timerinterval',{"$courseid\0$res"=>$interval},
 6087:                  $udom,$uname); 
 6088:             &appenv(
 6089:                      {
 6090:                         'course.'.$courseid.'.firstaccess.'.$res   => $start,
 6091:                         'course.'.$courseid.'.timerinterval.'.$res => $interval,
 6092:                      }
 6093:                   );
 6094:             if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
 6095:                 $cachedtimes{"$courseid\0$res"} = $start;
 6096:             }
 6097:         } elsif ($putres ne 'refused') {
 6098:             &logthis("Result: $putres when attempting to set first access time ".
 6099:                      "(type: $type, extent: $res) for $uname:$udom in $courseid");
 6100:         }
 6101:         return $putres;
 6102:     }
 6103:     return 'already_set';
 6104: }
 6105: }
 6106: 
 6107: # --------------------------------------------- Set Expire Date for Spreadsheet
 6108: 
 6109: sub expirespread {
 6110:     my ($uname,$udom,$stype,$usymb)=@_;
 6111:     my $cid=$env{'request.course.id'}; 
 6112:     if ($cid) {
 6113:        my $now=time;
 6114:        my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
 6115:        return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'.
 6116:                             $env{'course.'.$cid.'.num'}.
 6117: 	        	    ':nohist_expirationdates:'.
 6118:                             &escape($key).'='.$now,
 6119:                             $env{'course.'.$cid.'.home'})
 6120:     }
 6121:     return 'ok';
 6122: }
 6123: 
 6124: # ----------------------------------------------------- Devalidate Spreadsheets
 6125: 
 6126: sub devalidate {
 6127:     my ($symb,$uname,$udom)=@_;
 6128:     my $cid=$env{'request.course.id'}; 
 6129:     if ($cid) {
 6130:         # delete the stored spreadsheets for
 6131:         # - the student level sheet of this user in course's homespace
 6132:         # - the assessment level sheet for this resource 
 6133:         #   for this user in user's homespace
 6134: 	# - current conditional state info
 6135: 	my $key=$uname.':'.$udom.':';
 6136:         my $status=
 6137: 	    &del('nohist_calculatedsheets',
 6138: 		 [$key.'studentcalc:'],
 6139: 		 $env{'course.'.$cid.'.domain'},
 6140: 		 $env{'course.'.$cid.'.num'})
 6141: 		.' '.
 6142: 	    &del('nohist_calculatedsheets_'.$cid,
 6143: 		 [$key.'assesscalc:'.$symb],$udom,$uname);
 6144:         unless ($status eq 'ok ok') {
 6145:            &logthis('Could not devalidate spreadsheet '.
 6146:                     $uname.' at '.$udom.' for '.
 6147: 		    $symb.': '.$status);
 6148:         }
 6149: 	&delenv('user.state.'.$cid);
 6150:     }
 6151: }
 6152: 
 6153: sub get_scalar {
 6154:     my ($string,$end) = @_;
 6155:     my $value;
 6156:     if ($$string =~ s/^([^&]*?)($end)/$2/) {
 6157: 	$value = $1;
 6158:     } elsif ($$string =~ s/^([^&]*?)&//) {
 6159: 	$value = $1;
 6160:     }
 6161:     return &unescape($value);
 6162: }
 6163: 
 6164: sub array2str {
 6165:   my (@array) = @_;
 6166:   my $result=&arrayref2str(\@array);
 6167:   $result=~s/^__ARRAY_REF__//;
 6168:   $result=~s/__END_ARRAY_REF__$//;
 6169:   return $result;
 6170: }
 6171: 
 6172: sub arrayref2str {
 6173:   my ($arrayref) = @_;
 6174:   my $result='__ARRAY_REF__';
 6175:   foreach my $elem (@$arrayref) {
 6176:     if(ref($elem) eq 'ARRAY') {
 6177:       $result.=&arrayref2str($elem).'&';
 6178:     } elsif(ref($elem) eq 'HASH') {
 6179:       $result.=&hashref2str($elem).'&';
 6180:     } elsif(ref($elem)) {
 6181:       #print("Got a ref of ".(ref($elem))." skipping.");
 6182:     } else {
 6183:       $result.=&escape($elem).'&';
 6184:     }
 6185:   }
 6186:   $result=~s/\&$//;
 6187:   $result .= '__END_ARRAY_REF__';
 6188:   return $result;
 6189: }
 6190: 
 6191: sub hash2str {
 6192:   my (%hash) = @_;
 6193:   my $result=&hashref2str(\%hash);
 6194:   $result=~s/^__HASH_REF__//;
 6195:   $result=~s/__END_HASH_REF__$//;
 6196:   return $result;
 6197: }
 6198: 
 6199: sub hashref2str {
 6200:   my ($hashref)=@_;
 6201:   my $result='__HASH_REF__';
 6202:   foreach my $key (sort(keys(%$hashref))) {
 6203:     if (ref($key) eq 'ARRAY') {
 6204:       $result.=&arrayref2str($key).'=';
 6205:     } elsif (ref($key) eq 'HASH') {
 6206:       $result.=&hashref2str($key).'=';
 6207:     } elsif (ref($key)) {
 6208:       $result.='=';
 6209:       #print("Got a ref of ".(ref($key))." skipping.");
 6210:     } else {
 6211: 	if (defined($key)) {$result.=&escape($key).'=';} else { last; }
 6212:     }
 6213: 
 6214:     if(ref($hashref->{$key}) eq 'ARRAY') {
 6215:       $result.=&arrayref2str($hashref->{$key}).'&';
 6216:     } elsif(ref($hashref->{$key}) eq 'HASH') {
 6217:       $result.=&hashref2str($hashref->{$key}).'&';
 6218:     } elsif(ref($hashref->{$key})) {
 6219:        $result.='&';
 6220:       #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
 6221:     } else {
 6222:       $result.=&escape($hashref->{$key}).'&';
 6223:     }
 6224:   }
 6225:   $result=~s/\&$//;
 6226:   $result .= '__END_HASH_REF__';
 6227:   return $result;
 6228: }
 6229: 
 6230: sub str2hash {
 6231:     my ($string)=@_;
 6232:     my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
 6233:     return %$hash;
 6234: }
 6235: 
 6236: sub str2hashref {
 6237:   my ($string) = @_;
 6238: 
 6239:   my %hash;
 6240: 
 6241:   if($string !~ /^__HASH_REF__/) {
 6242:       if (! ($string eq '' || !defined($string))) {
 6243: 	  $hash{'error'}='Not hash reference';
 6244:       }
 6245:       return (\%hash, $string);
 6246:   }
 6247: 
 6248:   $string =~ s/^__HASH_REF__//;
 6249: 
 6250:   while($string !~ /^__END_HASH_REF__/) {
 6251:       #key
 6252:       my $key='';
 6253:       if($string =~ /^__HASH_REF__/) {
 6254:           ($key, $string)=&str2hashref($string);
 6255:           if(defined($key->{'error'})) {
 6256:               $hash{'error'}='Bad data';
 6257:               return (\%hash, $string);
 6258:           }
 6259:       } elsif($string =~ /^__ARRAY_REF__/) {
 6260:           ($key, $string)=&str2arrayref($string);
 6261:           if($key->[0] eq 'Array reference error') {
 6262:               $hash{'error'}='Bad data';
 6263:               return (\%hash, $string);
 6264:           }
 6265:       } else {
 6266:           $string =~ s/^(.*?)=//;
 6267: 	  $key=&unescape($1);
 6268:       }
 6269:       $string =~ s/^=//;
 6270: 
 6271:       #value
 6272:       my $value='';
 6273:       if($string =~ /^__HASH_REF__/) {
 6274:           ($value, $string)=&str2hashref($string);
 6275:           if(defined($value->{'error'})) {
 6276:               $hash{'error'}='Bad data';
 6277:               return (\%hash, $string);
 6278:           }
 6279:       } elsif($string =~ /^__ARRAY_REF__/) {
 6280:           ($value, $string)=&str2arrayref($string);
 6281:           if($value->[0] eq 'Array reference error') {
 6282:               $hash{'error'}='Bad data';
 6283:               return (\%hash, $string);
 6284:           }
 6285:       } else {
 6286: 	  $value=&get_scalar(\$string,'__END_HASH_REF__');
 6287:       }
 6288:       $string =~ s/^&//;
 6289: 
 6290:       $hash{$key}=$value;
 6291:   }
 6292: 
 6293:   $string =~ s/^__END_HASH_REF__//;
 6294: 
 6295:   return (\%hash, $string);
 6296: }
 6297: 
 6298: sub str2array {
 6299:     my ($string)=@_;
 6300:     my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
 6301:     return @$array;
 6302: }
 6303: 
 6304: sub str2arrayref {
 6305:   my ($string) = @_;
 6306:   my @array;
 6307: 
 6308:   if($string !~ /^__ARRAY_REF__/) {
 6309:       if (! ($string eq '' || !defined($string))) {
 6310: 	  $array[0]='Array reference error';
 6311:       }
 6312:       return (\@array, $string);
 6313:   }
 6314: 
 6315:   $string =~ s/^__ARRAY_REF__//;
 6316: 
 6317:   while($string !~ /^__END_ARRAY_REF__/) {
 6318:       my $value='';
 6319:       if($string =~ /^__HASH_REF__/) {
 6320:           ($value, $string)=&str2hashref($string);
 6321:           if(defined($value->{'error'})) {
 6322:               $array[0] ='Array reference error';
 6323:               return (\@array, $string);
 6324:           }
 6325:       } elsif($string =~ /^__ARRAY_REF__/) {
 6326:           ($value, $string)=&str2arrayref($string);
 6327:           if($value->[0] eq 'Array reference error') {
 6328:               $array[0] ='Array reference error';
 6329:               return (\@array, $string);
 6330:           }
 6331:       } else {
 6332: 	  $value=&get_scalar(\$string,'__END_ARRAY_REF__');
 6333:       }
 6334:       $string =~ s/^&//;
 6335: 
 6336:       push(@array, $value);
 6337:   }
 6338: 
 6339:   $string =~ s/^__END_ARRAY_REF__//;
 6340: 
 6341:   return (\@array, $string);
 6342: }
 6343: 
 6344: # -------------------------------------------------------------------Temp Store
 6345: 
 6346: sub tmpreset {
 6347:   my ($symb,$namespace,$domain,$stuname) = @_;
 6348:   if (!$symb) {
 6349:     $symb=&symbread();
 6350:     if (!$symb) { $symb= $env{'request.url'}; }
 6351:   }
 6352:   $symb=escape($symb);
 6353: 
 6354:   if (!$namespace) { $namespace=$env{'request.state'}; }
 6355:   $namespace=~s/\//\_/g;
 6356:   $namespace=~s/\W//g;
 6357: 
 6358:   if (!$domain) { $domain=$env{'user.domain'}; }
 6359:   if (!$stuname) { $stuname=$env{'user.name'}; }
 6360:   if ($domain eq 'public' && $stuname eq 'public') {
 6361:       $stuname=&get_requestor_ip();
 6362:   }
 6363:   my $path=LONCAPA::tempdir();
 6364:   my %hash;
 6365:   if (tie(%hash,'GDBM_File',
 6366: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 6367: 	  &GDBM_WRCREAT(),0640)) {
 6368:     foreach my $key (keys(%hash)) {
 6369:       if ($key=~ /:$symb/) {
 6370: 	delete($hash{$key});
 6371:       }
 6372:     }
 6373:   }
 6374: }
 6375: 
 6376: sub tmpstore {
 6377:   my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
 6378: 
 6379:   if (!$symb) {
 6380:     $symb=&symbread();
 6381:     if (!$symb) { $symb= $env{'request.url'}; }
 6382:   }
 6383:   $symb=escape($symb);
 6384: 
 6385:   if (!$namespace) {
 6386:     # I don't think we would ever want to store this for a course.
 6387:     # it seems this will only be used if we don't have a course.
 6388:     #$namespace=$env{'request.course.id'};
 6389:     #if (!$namespace) {
 6390:       $namespace=$env{'request.state'};
 6391:     #}
 6392:   }
 6393:   $namespace=~s/\//\_/g;
 6394:   $namespace=~s/\W//g;
 6395:   if (!$domain) { $domain=$env{'user.domain'}; }
 6396:   if (!$stuname) { $stuname=$env{'user.name'}; }
 6397:   if ($domain eq 'public' && $stuname eq 'public') {
 6398:       $stuname=&get_requestor_ip();
 6399:   }
 6400:   my $now=time;
 6401:   my %hash;
 6402:   my $path=LONCAPA::tempdir();
 6403:   if (tie(%hash,'GDBM_File',
 6404: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 6405: 	  &GDBM_WRCREAT(),0640)) {
 6406:     $hash{"version:$symb"}++;
 6407:     my $version=$hash{"version:$symb"};
 6408:     my $allkeys=''; 
 6409:     foreach my $key (keys(%$storehash)) {
 6410:       $allkeys.=$key.':';
 6411:       $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
 6412:     }
 6413:     $hash{"$version:$symb:timestamp"}=$now;
 6414:     $allkeys.='timestamp';
 6415:     $hash{"$version:keys:$symb"}=$allkeys;
 6416:     if (untie(%hash)) {
 6417:       return 'ok';
 6418:     } else {
 6419:       return "error:$!";
 6420:     }
 6421:   } else {
 6422:     return "error:$!";
 6423:   }
 6424: }
 6425: 
 6426: # -----------------------------------------------------------------Temp Restore
 6427: 
 6428: sub tmprestore {
 6429:   my ($symb,$namespace,$domain,$stuname) = @_;
 6430: 
 6431:   if (!$symb) {
 6432:     $symb=&symbread();
 6433:     if (!$symb) { $symb= $env{'request.url'}; }
 6434:   }
 6435:   $symb=escape($symb);
 6436: 
 6437:   if (!$namespace) { $namespace=$env{'request.state'}; }
 6438: 
 6439:   if (!$domain) { $domain=$env{'user.domain'}; }
 6440:   if (!$stuname) { $stuname=$env{'user.name'}; }
 6441:   if ($domain eq 'public' && $stuname eq 'public') {
 6442:       $stuname=&get_requestor_ip();
 6443:   }
 6444:   my %returnhash;
 6445:   $namespace=~s/\//\_/g;
 6446:   $namespace=~s/\W//g;
 6447:   my %hash;
 6448:   my $path=LONCAPA::tempdir();
 6449:   if (tie(%hash,'GDBM_File',
 6450: 	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
 6451: 	  &GDBM_READER(),0640)) {
 6452:     my $version=$hash{"version:$symb"};
 6453:     $returnhash{'version'}=$version;
 6454:     my $scope;
 6455:     for ($scope=1;$scope<=$version;$scope++) {
 6456:       my $vkeys=$hash{"$scope:keys:$symb"};
 6457:       my @keys=split(/:/,$vkeys);
 6458:       my $key;
 6459:       $returnhash{"$scope:keys"}=$vkeys;
 6460:       foreach $key (@keys) {
 6461: 	$returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
 6462: 	$returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
 6463:       }
 6464:     }
 6465:     if (!(untie(%hash))) {
 6466:       return "error:$!";
 6467:     }
 6468:   } else {
 6469:     return "error:$!";
 6470:   }
 6471:   return %returnhash;
 6472: }
 6473: 
 6474: # ----------------------------------------------------------------------- Store
 6475: 
 6476: sub store {
 6477:     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
 6478:     my $home='';
 6479: 
 6480:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 6481: 
 6482:     $symb=&symbclean($symb);
 6483:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 6484: 
 6485:     if (!$domain) { $domain=$env{'user.domain'}; }
 6486:     if (!$stuname) { $stuname=$env{'user.name'}; }
 6487: 
 6488:     &devalidate($symb,$stuname,$domain);
 6489: 
 6490:     $symb=escape($symb);
 6491:     if (!$namespace) { 
 6492:        unless ($namespace=$env{'request.course.id'}) { 
 6493:           return ''; 
 6494:        } 
 6495:     }
 6496:     if (!$home) { $home=$env{'user.home'}; }
 6497: 
 6498:     $$storehash{'ip'}=&get_requestor_ip();
 6499:     $$storehash{'host'}=$perlvar{'lonHostID'};
 6500: 
 6501:     my $namevalue='';
 6502:     foreach my $key (keys(%$storehash)) {
 6503:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 6504:     }
 6505:     $namevalue=~s/\&$//;
 6506:     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
 6507:     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 6508: }
 6509: 
 6510: # -------------------------------------------------------------- Critical Store
 6511: 
 6512: sub cstore {
 6513:     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
 6514:     my $home='';
 6515: 
 6516:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 6517: 
 6518:     $symb=&symbclean($symb);
 6519:     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 6520: 
 6521:     if (!$domain) { $domain=$env{'user.domain'}; }
 6522:     if (!$stuname) { $stuname=$env{'user.name'}; }
 6523: 
 6524:     &devalidate($symb,$stuname,$domain);
 6525: 
 6526:     $symb=escape($symb);
 6527:     if (!$namespace) { 
 6528:        unless ($namespace=$env{'request.course.id'}) { 
 6529:           return ''; 
 6530:        } 
 6531:     }
 6532:     if (!$home) { $home=$env{'user.home'}; }
 6533: 
 6534:     $$storehash{'ip'}=&get_requestor_ip();
 6535:     $$storehash{'host'}=$perlvar{'lonHostID'};
 6536: 
 6537:     my $namevalue='';
 6538:     foreach my $key (keys(%$storehash)) {
 6539:         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 6540:     }
 6541:     $namevalue=~s/\&$//;
 6542:     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
 6543:     return critical
 6544:                 ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 6545: }
 6546: 
 6547: # --------------------------------------------------------------------- Restore
 6548: 
 6549: sub restore {
 6550:     my ($symb,$namespace,$domain,$stuname) = @_;
 6551:     my $home='';
 6552: 
 6553:     if ($stuname) { $home=&homeserver($stuname,$domain); }
 6554: 
 6555:     if (!$symb) {
 6556:         return if ($namespace eq 'courserequests');
 6557:         unless ($symb=escape(&symbread())) { return ''; }
 6558:     } else {
 6559:         unless ($namespace eq 'courserequests') {
 6560:             $symb=&escape(&symbclean($symb));
 6561:         }
 6562:     }
 6563:     if (!$namespace) { 
 6564:        unless ($namespace=$env{'request.course.id'}) { 
 6565:           return ''; 
 6566:        } 
 6567:     }
 6568:     if (!$domain) { $domain=$env{'user.domain'}; }
 6569:     if (!$stuname) { $stuname=$env{'user.name'}; }
 6570:     if (!$home) { $home=$env{'user.home'}; }
 6571:     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
 6572: 
 6573:     my %returnhash=();
 6574:     foreach my $line (split(/\&/,$answer)) {
 6575: 	my ($name,$value)=split(/\=/,$line);
 6576:         $returnhash{&unescape($name)}=&thaw_unescape($value);
 6577:     }
 6578:     my $version;
 6579:     for ($version=1;$version<=$returnhash{'version'};$version++) {
 6580:        foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
 6581:           $returnhash{$item}=$returnhash{$version.':'.$item};
 6582:        }
 6583:     }
 6584:     return %returnhash;
 6585: }
 6586: 
 6587: # ---------------------------------------------------------- Course Description
 6588: #
 6589: #  
 6590: 
 6591: sub coursedescription {
 6592:     my ($courseid,$args)=@_;
 6593:     $courseid=~s/^\///;
 6594:     $courseid=~s/\_/\//g;
 6595:     my ($cdomain,$cnum)=split(/\//,$courseid);
 6596:     my $chome=&homeserver($cnum,$cdomain);
 6597:     my $normalid=$cdomain.'_'.$cnum;
 6598:     # need to always cache even if we get errors otherwise we keep 
 6599:     # trying and trying and trying to get the course description.
 6600:     my %envhash=();
 6601:     my %returnhash=();
 6602:     
 6603:     my $expiretime=600;
 6604:     if ($env{'request.course.id'} eq $normalid) {
 6605: 	$expiretime=120;
 6606:     }
 6607: 
 6608:     my $prefix='course.'.$cdomain.'_'.$cnum.'.';
 6609:     if (!$args->{'freshen_cache'}
 6610: 	&& ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
 6611: 	foreach my $key (keys(%env)) {
 6612: 	    next if ($key !~ /^\Q$prefix\E(.*)/);
 6613: 	    my ($setting) = $1;
 6614: 	    $returnhash{$setting} = $env{$key};
 6615: 	}
 6616: 	return %returnhash;
 6617:     }
 6618: 
 6619:     # get the data again
 6620: 
 6621:     if (!$args->{'one_time'}) {
 6622: 	$envhash{'course.'.$normalid.'.last_cache'}=time;
 6623:     }
 6624: 
 6625:     if ($chome ne 'no_host') {
 6626:        %returnhash=&dump('environment',$cdomain,$cnum);
 6627:        if (!exists($returnhash{'con_lost'})) {
 6628: 	   my $username = $env{'user.name'}; # Defult username
 6629: 	   if(defined $args->{'user'}) {
 6630: 	       $username = $args->{'user'};
 6631: 	   }
 6632:            $returnhash{'home'}= $chome;
 6633: 	   $returnhash{'domain'} = $cdomain;
 6634: 	   $returnhash{'num'} = $cnum;
 6635:            if (!defined($returnhash{'type'})) {
 6636:                $returnhash{'type'} = 'Course';
 6637:            }
 6638:            while (my ($name,$value) = each %returnhash) {
 6639:                $envhash{'course.'.$normalid.'.'.$name}=$value;
 6640:            }
 6641:            $returnhash{'url'}=&clutter($returnhash{'url'});
 6642:            $returnhash{'fn'}=LONCAPA::tempdir() .
 6643: 	       $username.'_'.$cdomain.'_'.$cnum;
 6644:            $envhash{'course.'.$normalid.'.home'}=$chome;
 6645:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
 6646:            $envhash{'course.'.$normalid.'.num'}=$cnum;
 6647:        }
 6648:     }
 6649:     if (!$args->{'one_time'}) {
 6650: 	&appenv(\%envhash);
 6651:     }
 6652:     return %returnhash;
 6653: }
 6654: 
 6655: sub update_released_required {
 6656:     my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_;
 6657:     if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') {
 6658:         $cid = $env{'request.course.id'};
 6659:         $cdom = $env{'course.'.$cid.'.domain'};
 6660:         $cnum = $env{'course.'.$cid.'.num'};
 6661:         $chome = $env{'course.'.$cid.'.home'};
 6662:     }
 6663:     if ($needsrelease) {
 6664:         my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired');
 6665:         my $needsupdate;
 6666:         if ($curr_reqd_hash{'internal.releaserequired'} eq '') {
 6667:             $needsupdate = 1;
 6668:         } else {
 6669:             my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
 6670:             my ($needsmajor,$needsminor) = split(/\./,$needsrelease);
 6671:             if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) {
 6672:                 $needsupdate = 1;
 6673:             }
 6674:         }
 6675:         if ($needsupdate) {
 6676:             my %needshash = (
 6677:                              'internal.releaserequired' => $needsrelease,
 6678:                             );
 6679:             my $putresult = &put('environment',\%needshash,$cdom,$cnum);
 6680:             if ($putresult eq 'ok') {
 6681:                 &appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease});
 6682:                 my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
 6683:                 if (ref($crsinfo{$cid}) eq 'HASH') {
 6684:                     $crsinfo{$cid}{'releaserequired'} = $needsrelease;
 6685:                     &courseidput($cdom,\%crsinfo,$chome,'notime');
 6686:                 }
 6687:             }
 6688:         }
 6689:     }
 6690:     return;
 6691: }
 6692: 
 6693: # -------------------------------------------------See if a user is privileged
 6694: 
 6695: sub privileged {
 6696:     my ($username,$domain,$possdomains,$possroles)=@_;
 6697:     my $now = time;
 6698:     my $roles;
 6699:     if (ref($possroles) eq 'ARRAY') {
 6700:         $roles = $possroles; 
 6701:     } else {
 6702:         $roles = ['dc','su'];
 6703:     }
 6704:     if (ref($possdomains) eq 'ARRAY') {
 6705:         my %privileged = &privileged_by_domain($possdomains,$roles);
 6706:         foreach my $dom (@{$possdomains}) {
 6707:             if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&
 6708:                 (ref($privileged{$dom}) eq 'HASH')) {
 6709:                 foreach my $role (@{$roles}) {
 6710:                     if (ref($privileged{$dom}{$role}) eq 'HASH') {
 6711:                         if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {
 6712:                             my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});
 6713:                             return 1 unless (($end && $end < $now) ||
 6714:                                              ($start && $start > $now));
 6715:                         }
 6716:                     }
 6717:                 }
 6718:             }
 6719:         }
 6720:     } else {
 6721:         my %rolesdump = &dump("roles", $domain, $username) or return 0;
 6722:         my $now = time;
 6723: 
 6724:         for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
 6725:             my ($trole, $tend, $tstart) = split(/_/, $role);
 6726:             if (grep(/^\Q$trole\E$/,@{$roles})) {
 6727:                 return 1 unless ($tend && $tend < $now) 
 6728:                         or ($tstart && $tstart > $now);
 6729:             }
 6730:         }
 6731:     }
 6732:     return 0;
 6733: }
 6734: 
 6735: sub privileged_by_domain {
 6736:     my ($domains,$roles) = @_;
 6737:     my %privileged = ();
 6738:     my $cachetime = 60*60*24;
 6739:     my $now = time;
 6740:     unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) {
 6741:         return %privileged;
 6742:     }
 6743:     foreach my $dom (@{$domains}) {
 6744:         next if (ref($privileged{$dom}) eq 'HASH');
 6745:         my $needroles;
 6746:         foreach my $role (@{$roles}) {
 6747:             my ($result,$cached)=&is_cached_new('priv_'.$role,$dom);
 6748:             if (defined($cached)) {
 6749:                 if (ref($result) eq 'HASH') {
 6750:                     $privileged{$dom}{$role} = $result;
 6751:                 }
 6752:             } else {
 6753:                 $needroles = 1;
 6754:             }
 6755:         }
 6756:         if ($needroles) {
 6757:             my %dompersonnel = &get_domain_roles($dom,$roles);
 6758:             $privileged{$dom} = {};
 6759:             foreach my $server (keys(%dompersonnel)) {
 6760:                 if (ref($dompersonnel{$server}) eq 'HASH') {
 6761:                     foreach my $item (keys(%{$dompersonnel{$server}})) {
 6762:                         my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
 6763:                         my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
 6764:                         next if ($end && $end < $now);
 6765:                         $privileged{$dom}{$trole}{$uname.':'.$udom} = 
 6766:                             $dompersonnel{$server}{$item};
 6767:                     }
 6768:                 }
 6769:             }
 6770:             if (ref($privileged{$dom}) eq 'HASH') {
 6771:                 foreach my $role (@{$roles}) {
 6772:                     if (ref($privileged{$dom}{$role}) eq 'HASH') {
 6773:                         &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime);
 6774:                     } else {
 6775:                         my %hash = ();
 6776:                         &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime);
 6777:                     }
 6778:                 }
 6779:             }
 6780:         }
 6781:     }
 6782:     return %privileged;
 6783: }
 6784: 
 6785: # -------------------------------------------------------- Get user privileges
 6786: 
 6787: sub rolesinit {
 6788:     my ($domain, $username) = @_;
 6789:     my %userroles = ('user.login.time' => time);
 6790:     my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
 6791: 
 6792:     # firstaccess and timerinterval are related to timed maps/resources. 
 6793:     # also, blocking can be triggered by an activating timer
 6794:     # it's saved in the user's %env.
 6795:     my %firstaccess = &dump('firstaccesstimes', $domain, $username);
 6796:     my %timerinterval = &dump('timerinterval', $domain, $username);
 6797:     my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
 6798:         %timerintchk, %timerintenv);
 6799: 
 6800:     foreach my $key (keys(%firstaccess)) {
 6801:         my ($cid, $rest) = split(/\0/, $key);
 6802:         $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
 6803:     }
 6804: 
 6805:     foreach my $key (keys(%timerinterval)) {
 6806:         my ($cid,$rest) = split(/\0/,$key);
 6807:         $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
 6808:     }
 6809: 
 6810:     my %allroles=();
 6811:     my %allgroups=();
 6812: 
 6813:     for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
 6814:         my $role = $rolesdump{$area};
 6815:         $area =~ s/\_\w\w$//;
 6816: 
 6817:         my ($trole, $tend, $tstart, $group_privs);
 6818: 
 6819:         if ($role =~ /^cr/) {
 6820:         # Custom role, defined by a user 
 6821:         # e.g., user.role.cr/msu/smith/mynewrole
 6822:             if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
 6823:                 $trole = $1;
 6824:                 ($tend, $tstart) = split('_', $2);
 6825:             } else {
 6826:                 $trole = $role;
 6827:             }
 6828:         } elsif ($role =~ m|^gr/|) {
 6829:         # Role of member in a group, defined within a course/community
 6830:         # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
 6831:             ($trole, $tend, $tstart) = split(/_/, $role);
 6832:             next if $tstart eq '-1';
 6833:             ($trole, $group_privs) = split(/\//, $trole);
 6834:             $group_privs = &unescape($group_privs);
 6835:         } else {
 6836:         # Just a normal role, defined in roles.tab
 6837:             ($trole, $tend, $tstart) = split(/_/,$role);
 6838:         }
 6839: 
 6840:         my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
 6841:                  $username);
 6842:         @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
 6843: 
 6844:         # role expired or not available yet?
 6845:         $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 
 6846:             ($tstart != 0 && $tstart > $userroles{'user.login.time'});
 6847: 
 6848:         next if $area eq '' or $trole eq '';
 6849: 
 6850:         my $spec = "$trole.$area";
 6851:         my ($tdummy, $tdomain, $trest) = split(/\//, $area);
 6852: 
 6853:         if ($trole =~ /^cr\//) {
 6854:         # Custom role, defined by a user
 6855:             &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
 6856:         } elsif ($trole eq 'gr') {
 6857:         # Role of a member in a group, defined within a course/community
 6858:             &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
 6859:             next;
 6860:         } else {
 6861:         # Normal role, defined in roles.tab
 6862:             &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
 6863:         }
 6864: 
 6865:         my $cid = $tdomain.'_'.$trest;
 6866:         unless ($firstaccchk{$cid}) {
 6867:             if (ref($coursetimerstarts{$cid}) eq 'HASH') {
 6868:                 foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
 6869:                     $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
 6870:                         $coursetimerstarts{$cid}{$item}; 
 6871:                 }
 6872:             }
 6873:             $firstaccchk{$cid} = 1;
 6874:         }
 6875:         unless ($timerintchk{$cid}) {
 6876:             if (ref($coursetimerintervals{$cid}) eq 'HASH') {
 6877:                 foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
 6878:                     $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
 6879:                        $coursetimerintervals{$cid}{$item};
 6880:                 }
 6881:             }
 6882:             $timerintchk{$cid} = 1;
 6883:         }
 6884:     }
 6885: 
 6886:     @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles,
 6887:                                                           \%allroles, \%allgroups);
 6888:     $env{'user.adv'} = $userroles{'user.adv'};
 6889:     $env{'user.rar'} = $userroles{'user.rar'};
 6890: 
 6891:     return (\%userroles,\%firstaccenv,\%timerintenv);
 6892: }
 6893: 
 6894: sub set_arearole {
 6895:     my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_;
 6896:     unless ($nolog) {
 6897: # log the associated role with the area
 6898:         &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
 6899:     }
 6900:     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 6901: }
 6902: 
 6903: sub custom_roleprivs {
 6904:     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
 6905:     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
 6906:     my $homsvr = &homeserver($rauthor,$rdomain);
 6907:     if (&hostname($homsvr) ne '') {
 6908:         my ($rdummy,$roledef)=
 6909:             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
 6910:         if (($rdummy ne 'con_lost') && ($roledef ne '')) {
 6911:             my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
 6912:             if (defined($syspriv)) {
 6913:                 if ($trest =~ /^$match_community$/) {
 6914:                     $syspriv =~ s/bre\&S//; 
 6915:                 }
 6916:                 $$allroles{'cm./'}.=':'.$syspriv;
 6917:                 $$allroles{$spec.'./'}.=':'.$syspriv;
 6918:             }
 6919:             if ($tdomain ne '') {
 6920:                 if (defined($dompriv)) {
 6921:                     $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
 6922:                     $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
 6923:                 }
 6924:                 if (($trest ne '') && (defined($coursepriv))) {
 6925:                     if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) {
 6926:                         my $rolename = $1;
 6927:                         $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv);
 6928:                     }
 6929:                     $$allroles{'cm.'.$area}.=':'.$coursepriv;
 6930:                     $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
 6931:                 }
 6932:             }
 6933:         }
 6934:     }
 6935: }
 6936: 
 6937: sub course_adhocrole_privs {
 6938:     my ($rolename,$cdom,$cnum,$coursepriv) = @_;
 6939:     my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum);
 6940:     if ($overrides{"internal.adhocpriv.$rolename"}) {
 6941:         my (%currprivs,%storeprivs);
 6942:         foreach my $item (split(/:/,$coursepriv)) {
 6943:             my ($priv,$restrict) = split(/\&/,$item);
 6944:             $currprivs{$priv} = $restrict;
 6945:         }
 6946:         my (%possadd,%possremove,%full);
 6947:         foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) {
 6948:             my ($priv,$restrict)=split(/\&/,$item);
 6949:             $full{$priv} = $restrict;
 6950:         }
 6951:         foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
 6952:             next if ($item eq '');
 6953:             my ($rule,$rest) = split(/=/,$item);
 6954:             next unless (($rule eq 'off') || ($rule eq 'on'));
 6955:             foreach my $priv (split(/:/,$rest)) {
 6956:                 if ($priv ne '') {
 6957:                     if ($rule eq 'off') {
 6958:                         $possremove{$priv} = 1;
 6959:                     } else {
 6960:                         $possadd{$priv} = 1;
 6961:                     }
 6962:                 }
 6963:             }
 6964:         }
 6965:         foreach my $priv (sort(keys(%full))) {
 6966:             if (exists($currprivs{$priv})) {
 6967:                 unless (exists($possremove{$priv})) {
 6968:                     $storeprivs{$priv} = $currprivs{$priv};
 6969:                 }
 6970:             } elsif (exists($possadd{$priv})) {
 6971:                 $storeprivs{$priv} = $full{$priv};
 6972:             }
 6973:         }
 6974:         $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
 6975:     }
 6976:     return $coursepriv;
 6977: }
 6978: 
 6979: sub group_roleprivs {
 6980:     my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
 6981:     my $access = 1;
 6982:     my $now = time;
 6983:     if (($tend!=0) && ($tend<$now)) { $access = 0; }
 6984:     if (($tstart!=0) && ($tstart>$now)) { $access=0; }
 6985:     if ($access) {
 6986:         my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
 6987:         $$allgroups{$course}{$group} .=':'.$group_privs;
 6988:     }
 6989: }
 6990: 
 6991: sub standard_roleprivs {
 6992:     my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
 6993:     if (defined($pr{$trole.':s'})) {
 6994:         $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
 6995:         $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
 6996:     }
 6997:     if ($tdomain ne '') {
 6998:         if (defined($pr{$trole.':d'})) {
 6999:             $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
 7000:             $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
 7001:         }
 7002:         if (($trest ne '') && (defined($pr{$trole.':c'}))) {
 7003:             $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
 7004:             $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
 7005:         }
 7006:     }
 7007: }
 7008: 
 7009: sub set_userprivs {
 7010:     my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 
 7011:     my $author=0;
 7012:     my $adv=0;
 7013:     my $rar=0;
 7014:     my %grouproles = ();
 7015:     if (keys(%{$allgroups}) > 0) {
 7016:         my @groupkeys; 
 7017:         foreach my $role (keys(%{$allroles})) {
 7018:             push(@groupkeys,$role);
 7019:         }
 7020:         if (ref($groups_roles) eq 'HASH') {
 7021:             foreach my $key (keys(%{$groups_roles})) {
 7022:                 unless (grep(/^\Q$key\E$/,@groupkeys)) {
 7023:                     push(@groupkeys,$key);
 7024:                 }
 7025:             }
 7026:         }
 7027:         if (@groupkeys > 0) {
 7028:             foreach my $role (@groupkeys) {
 7029:                 my ($trole,$area,$sec,$extendedarea);
 7030:                 if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
 7031:                     $trole = $1;
 7032:                     $area = $2;
 7033:                     $sec = $3;
 7034:                     $extendedarea = $area.$sec;
 7035:                     if (exists($$allgroups{$area})) {
 7036:                         foreach my $group (keys(%{$$allgroups{$area}})) {
 7037:                             my $spec = $trole.'.'.$extendedarea;
 7038:                             $grouproles{$spec.'.'.$area.'/'.$group} = 
 7039:                                                 $$allgroups{$area}{$group};
 7040:                         }
 7041:                     }
 7042:                 }
 7043:             }
 7044:         }
 7045:     }
 7046:     foreach my $group (keys(%grouproles)) {
 7047:         $$allroles{$group} = $grouproles{$group};
 7048:     }
 7049:     foreach my $role (keys(%{$allroles})) {
 7050:         my %thesepriv;
 7051:         if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
 7052:         foreach my $item (split(/:/,$$allroles{$role})) {
 7053:             if ($item ne '') {
 7054:                 my ($privilege,$restrictions)=split(/&/,$item);
 7055:                 if ($restrictions eq '') {
 7056:                     $thesepriv{$privilege}='F';
 7057:                 } elsif ($thesepriv{$privilege} ne 'F') {
 7058:                     $thesepriv{$privilege}.=$restrictions;
 7059:                 }
 7060:                 if ($thesepriv{'adv'} eq 'F') { $adv=1; }
 7061:                 if ($thesepriv{'rar'} eq 'F') { $rar=1; }
 7062:             }
 7063:         }
 7064:         my $thesestr='';
 7065:         foreach my $priv (sort(keys(%thesepriv))) {
 7066: 	    $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
 7067: 	}
 7068:         $userroles->{'user.priv.'.$role} = $thesestr;
 7069:     }
 7070:     return ($author,$adv,$rar);
 7071: }
 7072: 
 7073: sub role_status {
 7074:     my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
 7075:     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
 7076:         my ($one,$two) = split(m{\./},$rolekey,2);
 7077:         (undef,undef,$$role) = split(/\./,$one,3);
 7078:         unless (!defined($$role) || $$role eq '') {
 7079:             $$where = '/'.$two;
 7080:             $$trolecode=$$role.'.'.$$where;
 7081:             ($$tstart,$$tend)=split(/\./,$env{$rolekey});
 7082:             $$tstatus='is';
 7083:             if ($$tstart && $$tstart>$update) {
 7084:                 $$tstatus='future';
 7085:                 if ($$tstart<$now) {
 7086:                     if ($$tstart && $$tstart>$refresh) {
 7087:                         if (($$where ne '') && ($$role ne '')) {
 7088:                             my (%allroles,%allgroups,$group_privs,
 7089:                                 %groups_roles,@rolecodes);
 7090:                             my %userroles = (
 7091:                                 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
 7092:                             );
 7093:                             @rolecodes = ('cm'); 
 7094:                             my $spec=$$role.'.'.$$where;
 7095:                             my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
 7096:                             if ($$role =~ /^cr\//) {
 7097:                                 &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
 7098:                                 push(@rolecodes,'cr');
 7099:                             } elsif ($$role eq 'gr') {
 7100:                                 push(@rolecodes,$$role);
 7101:                                 my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
 7102:                                                     $env{'user.name'});
 7103:                                 my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);
 7104:                                 (undef,my $group_privs) = split(/\//,$trole);
 7105:                                 $group_privs = &unescape($group_privs);
 7106:                                 &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
 7107:                                 my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
 7108:                                 &get_groups_roles($tdomain,$trest,
 7109:                                                   \%course_roles,\@rolecodes,
 7110:                                                   \%groups_roles);
 7111:                             } else {
 7112:                                 push(@rolecodes,$$role);
 7113:                                 &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
 7114:                             }
 7115:                             my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups,
 7116:                                                                    \%groups_roles);
 7117:                             &appenv(\%userroles,\@rolecodes);
 7118:                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
 7119:                         }
 7120:                     }
 7121:                     $$tstatus = 'is';
 7122:                 }
 7123:             }
 7124:             if ($$tend) {
 7125:                 if ($$tend<$update) {
 7126:                     $$tstatus='expired';
 7127:                 } elsif ($$tend<$now) {
 7128:                     $$tstatus='will_not';
 7129:                 }
 7130:             }
 7131:         }
 7132:     }
 7133: }
 7134: 
 7135: sub get_groups_roles {
 7136:     my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_;
 7137:     return unless((ref($cdom_courseroles) eq 'HASH') && 
 7138:                   (ref($rolecodes) eq 'ARRAY') && 
 7139:                   (ref($groups_roles) eq 'HASH')); 
 7140:     if (keys(%{$cdom_courseroles}) > 0) {
 7141:         my ($cnum) = ($rest =~ /^($match_courseid)/);
 7142:         if ($cdom ne '' && $cnum ne '') {
 7143:             foreach my $key (keys(%{$cdom_courseroles})) {
 7144:                 if ($key =~ /^\Q$cnum\E:\Q$cdom\E:([^:]+):?([^:]*)/) {
 7145:                     my $crsrole = $1;
 7146:                     my $crssec = $2;
 7147:                     if ($crsrole =~ /^cr/) {
 7148:                         unless (grep(/^cr$/,@{$rolecodes})) {
 7149:                             push(@{$rolecodes},'cr');
 7150:                         }
 7151:                     } else {
 7152:                         unless(grep(/^\Q$crsrole\E$/,@{$rolecodes})) {
 7153:                             push(@{$rolecodes},$crsrole);
 7154:                         }
 7155:                     }
 7156:                     my $rolekey = "$crsrole./$cdom/$cnum";
 7157:                     if ($crssec ne '') {
 7158:                         $rolekey .= "/$crssec";
 7159:                     }
 7160:                     $rolekey .= './';
 7161:                     $groups_roles->{$rolekey} = $rolecodes;
 7162:                 }
 7163:             }
 7164:         }
 7165:     }
 7166:     return;
 7167: }
 7168: 
 7169: sub delete_env_groupprivs {
 7170:     my ($where,$courseroles,$possroles) = @_;
 7171:     return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY'));
 7172:     my ($dummy,$udom,$uname,$group) = split(/\//,$where);
 7173:     unless (ref($courseroles->{$udom}) eq 'HASH') {
 7174:         %{$courseroles->{$udom}} =
 7175:             &get_my_roles('','','userroles',['active'],
 7176:                           $possroles,[$udom],1);
 7177:     }
 7178:     if (ref($courseroles->{$udom}) eq 'HASH') {
 7179:         foreach my $item (keys(%{$courseroles->{$udom}})) {
 7180:             my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item);
 7181:             my $area = '/'.$cdom.'/'.$cnum;
 7182:             my $privkey = "user.priv.$crsrole.$area";
 7183:             if ($crssec ne '') {
 7184:                 $privkey .= '/'.$crssec;
 7185:             }
 7186:             $privkey .= ".$area/$group";
 7187:             &Apache::lonnet::delenv($privkey,undef,[$crsrole]);
 7188:         }
 7189:     }
 7190:     return;
 7191: }
 7192: 
 7193: sub check_adhoc_privs {
 7194:     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_;
 7195:     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
 7196:     if ($sec) {
 7197:         $cckey .= '/'.$sec;
 7198:     } 
 7199:     my $setprivs;
 7200:     if ($env{$cckey}) {
 7201:         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
 7202:         &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
 7203:         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
 7204:             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
 7205:             $setprivs = 1;
 7206:         }
 7207:     } else {
 7208:         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
 7209:         $setprivs = 1;
 7210:     }
 7211:     return $setprivs;
 7212: }
 7213: 
 7214: sub set_adhoc_privileges {
 7215: # role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role
 7216:     my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_;
 7217:     my $area = '/'.$dcdom.'/'.$pickedcourse;
 7218:     if ($sec ne '') {
 7219:         $area .= '/'.$sec;
 7220:     }
 7221:     my $spec = $role.'.'.$area;
 7222:     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
 7223:                                   $env{'user.name'},1);
 7224:     my %rolehash = ();
 7225:     if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) {
 7226:         my $rolename = $1;
 7227:         &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area);
 7228:         my %domdef = &get_domain_defaults($dcdom);
 7229:         if (ref($domdef{'adhocroles'}) eq 'HASH') {
 7230:             if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') {
 7231:                 &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},});
 7232:             }
 7233:         }
 7234:     } else {
 7235:         &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
 7236:     }
 7237:     my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
 7238:     &appenv(\%userroles,[$role,'cm']);
 7239:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
 7240:     unless (($caller eq 'constructaccess' && $env{'request.course.id'}) ||
 7241:             ($caller eq 'tiny')) {
 7242:         &appenv( {'request.role'        => $spec,
 7243:                   'request.role.domain' => $dcdom,
 7244:                   'request.course.sec'  => $sec,
 7245:                  }
 7246:                );
 7247:         my $tadv=0;
 7248:         if (&allowed('adv') eq 'F') { $tadv=1; }
 7249:         &appenv({'request.role.adv'    => $tadv});
 7250:     }
 7251: }
 7252: 
 7253: # --------------------------------------------------------------- get interface
 7254: 
 7255: sub get {
 7256:    my ($namespace,$storearr,$udomain,$uname)=@_;
 7257:    my $items='';
 7258:    foreach my $item (@$storearr) {
 7259:        $items.=&escape($item).'&';
 7260:    }
 7261:    $items=~s/\&$//;
 7262:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7263:    if (!$uname) { $uname=$env{'user.name'}; }
 7264:    my $uhome=&homeserver($uname,$udomain);
 7265: 
 7266:    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
 7267:    my @pairs=split(/\&/,$rep);
 7268:    if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
 7269:      return @pairs;
 7270:    }
 7271:    my %returnhash=();
 7272:    my $i=0;
 7273:    foreach my $item (@$storearr) {
 7274:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
 7275:       $i++;
 7276:    }
 7277:    return %returnhash;
 7278: }
 7279: 
 7280: # --------------------------------------------------------------- del interface
 7281: 
 7282: sub del {
 7283:    my ($namespace,$storearr,$udomain,$uname)=@_;
 7284:    my $items='';
 7285:    foreach my $item (@$storearr) {
 7286:        $items.=&escape($item).'&';
 7287:    }
 7288: 
 7289:    $items=~s/\&$//;
 7290:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7291:    if (!$uname) { $uname=$env{'user.name'}; }
 7292:    my $uhome=&homeserver($uname,$udomain);
 7293:    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 7294: }
 7295: 
 7296: # -------------------------------------------------------------- dump interface
 7297: 
 7298: sub unserialize {
 7299:     my ($rep, $escapedkeys) = @_;
 7300: 
 7301:     return {} if $rep =~ /^error/;
 7302: 
 7303:     my %returnhash=();
 7304: 	foreach my $item (split(/\&/,$rep)) {
 7305: 	    my ($key, $value) = split(/=/, $item, 2);
 7306: 	    $key = unescape($key) unless $escapedkeys;
 7307: 	    next if $key =~ /^error: 2 /;
 7308: 	    $returnhash{$key} = &thaw_unescape($value);
 7309: 	}
 7310:     #return %returnhash;
 7311:     return \%returnhash;
 7312: }        
 7313: 
 7314: # see Lond::dump_with_regexp
 7315: # if $escapedkeys hash keys won't get unescaped.
 7316: sub dump {
 7317:     my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
 7318:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 7319:     if (!$uname) { $uname=$env{'user.name'}; }
 7320:     my $uhome=&homeserver($uname,$udomain);
 7321: 
 7322:     if ($regexp) {
 7323:         $regexp=&escape($regexp);
 7324:     } else {
 7325:         $regexp='.';
 7326:     }
 7327:     if (grep { $_ eq $uhome } current_machine_ids()) {
 7328:         # user is hosted on this machine
 7329:         my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
 7330:                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
 7331:         return %{unserialize($reply, $escapedkeys)};
 7332:     }
 7333:     my $rep;
 7334:     if ($encrypt) {
 7335:         $rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
 7336:     } else {
 7337:         $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
 7338:     }
 7339:     my @pairs=split(/\&/,$rep);
 7340:     my %returnhash=();
 7341:     if (!($rep =~ /^error/ )) {
 7342: 	foreach my $item (@pairs) {
 7343: 	    my ($key,$value)=split(/=/,$item,2);
 7344:         $key = unescape($key) unless $escapedkeys;
 7345:         #$key = &unescape($key);
 7346: 	    next if ($key =~ /^error: 2 /);
 7347: 	    $returnhash{$key}=&thaw_unescape($value);
 7348: 	}
 7349:     }
 7350:     return %returnhash;
 7351: }
 7352: 
 7353: 
 7354: # --------------------------------------------------------- dumpstore interface
 7355: 
 7356: sub dumpstore {
 7357:    my ($namespace,$udomain,$uname,$regexp,$range)=@_;
 7358:    # same as dump but keys must be escaped. They may contain colon separated
 7359:    # lists of values that may themself contain colons (e.g. symbs).
 7360:    return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
 7361: }
 7362: 
 7363: # -------------------------------------------------------------- keys interface
 7364: 
 7365: sub getkeys {
 7366:    my ($namespace,$udomain,$uname)=@_;
 7367:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7368:    if (!$uname) { $uname=$env{'user.name'}; }
 7369:    my $uhome=&homeserver($uname,$udomain);
 7370:    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
 7371:    my @keyarray=();
 7372:    foreach my $key (split(/\&/,$rep)) {
 7373:       next if ($key =~ /^error: 2 /);
 7374:       push(@keyarray,&unescape($key));
 7375:    }
 7376:    return @keyarray;
 7377: }
 7378: 
 7379: # --------------------------------------------------------------- currentdump
 7380: sub currentdump {
 7381:    my ($courseid,$sdom,$sname)=@_;
 7382:    $courseid = $env{'request.course.id'} if (! defined($courseid));
 7383:    $sdom     = $env{'user.domain'}       if (! defined($sdom));
 7384:    $sname    = $env{'user.name'}         if (! defined($sname));
 7385:    my $uhome = &homeserver($sname,$sdom);
 7386:    my $rep;
 7387: 
 7388:    if (grep { $_ eq $uhome } current_machine_ids()) {
 7389:        $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 
 7390:                    $courseid)));
 7391:    } else {
 7392:        $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
 7393:    }
 7394: 
 7395:    return if ($rep =~ /^(error:|no_such_host)/);
 7396:    #
 7397:    my %returnhash=();
 7398:    #
 7399:    if ($rep eq 'unknown_cmd') {
 7400:        # an old lond will not know currentdump
 7401:        # Do a dump and make it look like a currentdump
 7402:        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
 7403:        return if ($tmp[0] =~ /^(error:|no_such_host)/);
 7404:        my %hash = @tmp;
 7405:        @tmp=();
 7406:        %returnhash = %{&convert_dump_to_currentdump(\%hash)};
 7407:    } else {
 7408:        my @pairs=split(/\&/,$rep);
 7409:        foreach my $pair (@pairs) {
 7410:            my ($key,$value)=split(/=/,$pair,2);
 7411:            my ($symb,$param) = split(/:/,$key);
 7412:            $returnhash{&unescape($symb)}->{&unescape($param)} = 
 7413:                                                         &thaw_unescape($value);
 7414:        }
 7415:    }
 7416:    return %returnhash;
 7417: }
 7418: 
 7419: sub convert_dump_to_currentdump{
 7420:     my %hash = %{shift()};
 7421:     my %returnhash;
 7422:     # Code ripped from lond, essentially.  The only difference
 7423:     # here is the unescaping done by lonnet::dump().  Conceivably
 7424:     # we might run in to problems with parameter names =~ /^v\./
 7425:     while (my ($key,$value) = each(%hash)) {
 7426:         my ($v,$symb,$param) = split(/:/,$key);
 7427: 	$symb  = &unescape($symb);
 7428: 	$param = &unescape($param);
 7429:         next if ($v eq 'version' || $symb eq 'keys');
 7430:         next if (exists($returnhash{$symb}) &&
 7431:                  exists($returnhash{$symb}->{$param}) &&
 7432:                  $returnhash{$symb}->{'v.'.$param} > $v);
 7433:         $returnhash{$symb}->{$param}=$value;
 7434:         $returnhash{$symb}->{'v.'.$param}=$v;
 7435:     }
 7436:     #
 7437:     # Remove all of the keys in the hashes which keep track of
 7438:     # the version of the parameter.
 7439:     while (my ($symb,$param_hash) = each(%returnhash)) {
 7440:         # use a foreach because we are going to delete from the hash.
 7441:         foreach my $key (keys(%$param_hash)) {
 7442:             delete($param_hash->{$key}) if ($key =~ /^v\./);
 7443:         }
 7444:     }
 7445:     return \%returnhash;
 7446: }
 7447: 
 7448: # ------------------------------------------------------ critical inc interface
 7449: 
 7450: sub cinc {
 7451:     return &inc(@_,'critical');
 7452: }
 7453: 
 7454: # --------------------------------------------------------------- inc interface
 7455: 
 7456: sub inc {
 7457:     my ($namespace,$store,$udomain,$uname,$critical) = @_;
 7458:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 7459:     if (!$uname) { $uname=$env{'user.name'}; }
 7460:     my $uhome=&homeserver($uname,$udomain);
 7461:     my $items='';
 7462:     if (! ref($store)) {
 7463:         # got a single value, so use that instead
 7464:         $items = &escape($store).'=&';
 7465:     } elsif (ref($store) eq 'SCALAR') {
 7466:         $items = &escape($$store).'=&';        
 7467:     } elsif (ref($store) eq 'ARRAY') {
 7468:         $items = join('=&',map {&escape($_);} @{$store});
 7469:     } elsif (ref($store) eq 'HASH') {
 7470:         while (my($key,$value) = each(%{$store})) {
 7471:             $items.= &escape($key).'='.&escape($value).'&';
 7472:         }
 7473:     }
 7474:     $items=~s/\&$//;
 7475:     if ($critical) {
 7476: 	return &critical("inc:$udomain:$uname:$namespace:$items",$uhome);
 7477:     } else {
 7478: 	return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
 7479:     }
 7480: }
 7481: 
 7482: # --------------------------------------------------------------- put interface
 7483: 
 7484: sub put {
 7485:    my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
 7486:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7487:    if (!$uname) { $uname=$env{'user.name'}; }
 7488:    my $uhome=&homeserver($uname,$udomain);
 7489:    my $items='';
 7490:    foreach my $item (keys(%$storehash)) {
 7491:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 7492:    }
 7493:    $items=~s/\&$//;
 7494:    if ($encrypt) {
 7495:        return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);
 7496:    } else {
 7497:        return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 7498:    }
 7499: }
 7500: 
 7501: # ------------------------------------------------------------ newput interface
 7502: 
 7503: sub newput {
 7504:    my ($namespace,$storehash,$udomain,$uname)=@_;
 7505:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7506:    if (!$uname) { $uname=$env{'user.name'}; }
 7507:    my $uhome=&homeserver($uname,$udomain);
 7508:    my $items='';
 7509:    foreach my $key (keys(%$storehash)) {
 7510:        $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
 7511:    }
 7512:    $items=~s/\&$//;
 7513:    return &reply("newput:$udomain:$uname:$namespace:$items",$uhome);
 7514: }
 7515: 
 7516: # ---------------------------------------------------------  putstore interface
 7517: 
 7518: sub putstore {
 7519:    my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;
 7520:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7521:    if (!$uname) { $uname=$env{'user.name'}; }
 7522:    my $uhome=&homeserver($uname,$udomain);
 7523:    my $items='';
 7524:    foreach my $key (keys(%$storehash)) {
 7525:        $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
 7526:    }
 7527:    $items=~s/\&$//;
 7528:    my $esc_symb=&escape($symb);
 7529:    my $esc_v=&escape($version);
 7530:    my $reply =
 7531:        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
 7532: 	      $uhome);
 7533:    if (($tolog) && ($reply eq 'ok')) {
 7534:        my $namevalue='';
 7535:        foreach my $key (keys(%{$storehash})) {
 7536:            $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
 7537:        }
 7538:        my $ip = &get_requestor_ip();
 7539:        $namevalue .= 'ip='.&escape($ip).
 7540:                      '&host='.&escape($perlvar{'lonHostID'}).
 7541:                      '&version='.$esc_v.
 7542:                      '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
 7543:        &courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
 7544:    }
 7545:    if ($reply eq 'unknown_cmd') {
 7546:        # gfall back to way things use to be done
 7547:        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
 7548: 			    $uname);
 7549:    }
 7550:    return $reply;
 7551: }
 7552: 
 7553: sub old_putstore {
 7554:     my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
 7555:     if (!$udomain) { $udomain=$env{'user.domain'}; }
 7556:     if (!$uname) { $uname=$env{'user.name'}; }
 7557:     my $uhome=&homeserver($uname,$udomain);
 7558:     my %newstorehash;
 7559:     foreach my $item (keys(%$storehash)) {
 7560: 	my $key = $version.':'.&escape($symb).':'.$item;
 7561: 	$newstorehash{$key} = $storehash->{$item};
 7562:     }
 7563:     my $items='';
 7564:     my %allitems = ();
 7565:     foreach my $item (keys(%newstorehash)) {
 7566: 	if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
 7567: 	    my $key = $1.':keys:'.$2;
 7568: 	    $allitems{$key} .= $3.':';
 7569: 	}
 7570: 	$items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
 7571:     }
 7572:     foreach my $item (keys(%allitems)) {
 7573: 	$allitems{$item} =~ s/\:$//;
 7574: 	$items.= $item.'='.$allitems{$item}.'&';
 7575:     }
 7576:     $items=~s/\&$//;
 7577:     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 7578: }
 7579: 
 7580: # ------------------------------------------------------ critical put interface
 7581: 
 7582: sub cput {
 7583:    my ($namespace,$storehash,$udomain,$uname)=@_;
 7584:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7585:    if (!$uname) { $uname=$env{'user.name'}; }
 7586:    my $uhome=&homeserver($uname,$udomain);
 7587:    my $items='';
 7588:    foreach my $item (keys(%$storehash)) {
 7589:        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 7590:    }
 7591:    $items=~s/\&$//;
 7592:    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
 7593: }
 7594: 
 7595: # -------------------------------------------------------------- eget interface
 7596: 
 7597: sub eget {
 7598:    my ($namespace,$storearr,$udomain,$uname)=@_;
 7599:    my $items='';
 7600:    foreach my $item (@$storearr) {
 7601:        $items.=&escape($item).'&';
 7602:    }
 7603:    $items=~s/\&$//;
 7604:    if (!$udomain) { $udomain=$env{'user.domain'}; }
 7605:    if (!$uname) { $uname=$env{'user.name'}; }
 7606:    my $uhome=&homeserver($uname,$udomain);
 7607:    my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
 7608:    my @pairs=split(/\&/,$rep);
 7609:    my %returnhash=();
 7610:    my $i=0;
 7611:    foreach my $item (@$storearr) {
 7612:       $returnhash{$item}=&thaw_unescape($pairs[$i]);
 7613:       $i++;
 7614:    }
 7615:    return %returnhash;
 7616: }
 7617: 
 7618: # ------------------------------------------------------------ tmpput interface
 7619: sub tmpput {
 7620:     my ($storehash,$server,$context)=@_;
 7621:     my $items='';
 7622:     foreach my $item (keys(%$storehash)) {
 7623: 	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
 7624:     }
 7625:     $items=~s/\&$//;
 7626:     if (defined($context)) {
 7627:         $items .= ':'.&escape($context);
 7628:     }
 7629:     return &reply("tmpput:$items",$server);
 7630: }
 7631: 
 7632: # ------------------------------------------------------------ tmpget interface
 7633: sub tmpget {
 7634:     my ($token,$server)=@_;
 7635:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
 7636:     my $rep=&reply("tmpget:$token",$server);
 7637:     my %returnhash;
 7638:     if ($rep =~ /^(con_lost|error|no_such_host)/i) {
 7639:         return %returnhash;
 7640:     }
 7641:     foreach my $item (split(/\&/,$rep)) {
 7642: 	my ($key,$value)=split(/=/,$item);
 7643: 	$returnhash{&unescape($key)}=&thaw_unescape($value);
 7644:     }
 7645:     return %returnhash;
 7646: }
 7647: 
 7648: # ------------------------------------------------------------ tmpdel interface
 7649: sub tmpdel {
 7650:     my ($token,$server)=@_;
 7651:     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
 7652:     return &reply("tmpdel:$token",$server);
 7653: }
 7654: 
 7655: # ------------------------------------------------------------ get_timebased_id 
 7656: 
 7657: sub get_timebased_id {
 7658:     my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
 7659:         $maxtries) = @_;
 7660:     my ($newid,$error,$dellock);
 7661:     unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {  
 7662:         return ('','ok','invalid call to get suffix');
 7663:     }
 7664: 
 7665: # set defaults for any optional args for which values were not supplied
 7666:     if ($who eq '') {
 7667:         $who = $env{'user.name'}.':'.$env{'user.domain'};
 7668:     }
 7669:     if (!$locktries) {
 7670:         $locktries = 3;
 7671:     }
 7672:     if (!$maxtries) {
 7673:         $maxtries = 10;
 7674:     }
 7675:     
 7676:     if (($cdom eq '') || ($cnum eq '')) {
 7677:         if ($env{'request.course.id'}) {
 7678:             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 7679:             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
 7680:         }
 7681:         if (($cdom eq '') || ($cnum eq '')) {
 7682:             return ('','ok','call to get suffix not in course context');
 7683:         }
 7684:     }
 7685: 
 7686: # construct locking item
 7687:     my $lockhash = {
 7688:                       $prefix."\0".'locked_'.$keyid => $who,
 7689:                    };
 7690:     my $tries = 0;
 7691: 
 7692: # attempt to get lock on nohist_$namespace file
 7693:     my $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
 7694:     while (($gotlock ne 'ok') && $tries <$locktries) {
 7695:         $tries ++;
 7696:         sleep 1;
 7697:         $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
 7698:     }
 7699: 
 7700: # attempt to get unique identifier, based on current timestamp
 7701:     if ($gotlock eq 'ok') {
 7702:         my %inuse = &dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
 7703:         my $id = time;
 7704:         $newid = $id;
 7705:         if ($idtype eq 'addcode') {
 7706:             $newid .= &sixnum_code();
 7707:         }
 7708:         my $idtries = 0;
 7709:         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
 7710:             if ($idtype eq 'concat') {
 7711:                 $newid = $id.$idtries;
 7712:             } elsif ($idtype eq 'addcode') {
 7713:                 $newid = $newid.&sixnum_code();
 7714:             } else {
 7715:                 $newid ++;
 7716:             }
 7717:             $idtries ++;
 7718:         }
 7719:         if (!exists($inuse{$prefix."\0".$newid})) {
 7720:             my %new_item =  (
 7721:                               $prefix."\0".$newid => $who,
 7722:                             );
 7723:             my $putresult = &put('nohist_'.$namespace,\%new_item,
 7724:                                                  $cdom,$cnum);
 7725:             if ($putresult ne 'ok') {
 7726:                 undef($newid);
 7727:                 $error = 'error saving new item: '.$putresult;
 7728:             }
 7729:         } else {
 7730:              undef($newid);
 7731:              $error = ('error: no unique suffix available for the new item ');
 7732:         }
 7733: #  remove lock
 7734:         my @del_lock = ($prefix."\0".'locked_'.$keyid);
 7735:         $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum);
 7736:     } else {
 7737:         $error = "error: could not obtain lockfile\n";
 7738:         $dellock = 'ok';
 7739:         if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {
 7740:             $dellock = 'nolock';
 7741:         }
 7742:     }
 7743:     return ($newid,$dellock,$error);
 7744: }
 7745: 
 7746: sub sixnum_code {
 7747:     my $code;
 7748:     for (0..6) {
 7749:         $code .= int( rand(9) );
 7750:     }
 7751:     return $code;
 7752: }
 7753: 
 7754: # -------------------------------------------------- portfolio access checking
 7755: 
 7756: sub portfolio_access {
 7757:     my ($requrl,$clientip) = @_;
 7758:     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
 7759:     my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);
 7760:     if ($result) {
 7761:         my %setters;
 7762:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
 7763:             my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
 7764:                 &Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
 7765:             if (($startblock && $endblock) || ($by_ip)) {
 7766:                 return 'B';
 7767:             }
 7768:         } else {
 7769:             my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
 7770:                 &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
 7771:             if (($startblock && $endblock) || ($by_ip)) {
 7772:                 return 'B';
 7773:             }
 7774:         }
 7775:     }
 7776:     if ($result eq 'ok') {
 7777:        return 'F';
 7778:     } elsif ($result =~ /^[^:]+:guest_/) {
 7779:        return 'A';
 7780:     }
 7781:     return '';
 7782: }
 7783: 
 7784: sub get_portfolio_access {
 7785:     my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
 7786: 
 7787:     if (!ref($access_hash)) {
 7788: 	my $current_perms = &get_portfile_permissions($udom,$unum);
 7789: 	my %access_controls = &get_access_controls($current_perms,$group,
 7790: 						   $file_name);
 7791: 	$access_hash = $access_controls{$file_name};
 7792:     }
 7793: 
 7794:     my ($public,$guest,@domains,@users,@courses,@groups,@ips);
 7795:     my $now = time;
 7796:     if (ref($access_hash) eq 'HASH') {
 7797:         foreach my $key (keys(%{$access_hash})) {
 7798:             my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
 7799:             if ($start > $now) {
 7800:                 next;
 7801:             }
 7802:             if ($end && $end<$now) {
 7803:                 next;
 7804:             }
 7805:             if ($scope eq 'public') {
 7806:                 $public = $key;
 7807:                 last;
 7808:             } elsif ($scope eq 'guest') {
 7809:                 $guest = $key;
 7810:             } elsif ($scope eq 'domains') {
 7811:                 push(@domains,$key);
 7812:             } elsif ($scope eq 'users') {
 7813:                 push(@users,$key);
 7814:             } elsif ($scope eq 'course') {
 7815:                 push(@courses,$key);
 7816:             } elsif ($scope eq 'group') {
 7817:                 push(@groups,$key);
 7818:             } elsif ($scope eq 'ip') {
 7819:                 push(@ips,$key);
 7820:             }
 7821:         }
 7822:         if ($public) {
 7823:             return 'ok';
 7824:         } elsif (@ips > 0) {
 7825:             my $allowed;
 7826:             foreach my $ipkey (@ips) {
 7827:                 if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
 7828:                     if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
 7829:                         $allowed = 1;
 7830:                         last; 
 7831:                     }
 7832:                 }
 7833:             }
 7834:             if ($allowed) {
 7835:                 return 'ok';
 7836:             }
 7837:         }
 7838:         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
 7839:             if ($guest) {
 7840:                 return $guest;
 7841:             }
 7842:         } else {
 7843:             if (@domains > 0) {
 7844:                 foreach my $domkey (@domains) {
 7845:                     if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
 7846:                         if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
 7847:                             return 'ok';
 7848:                         }
 7849:                     }
 7850:                 }
 7851:             }
 7852:             if (@users > 0) {
 7853:                 foreach my $userkey (@users) {
 7854:                     if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
 7855:                         foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
 7856:                             if (ref($item) eq 'HASH') {
 7857:                                 if (($item->{'uname'} eq $env{'user.name'}) &&
 7858:                                     ($item->{'udom'} eq $env{'user.domain'})) {
 7859:                                     return 'ok';
 7860:                                 }
 7861:                             }
 7862:                         }
 7863:                     } 
 7864:                 }
 7865:             }
 7866:             my %roleshash;
 7867:             my @courses_and_groups = @courses;
 7868:             push(@courses_and_groups,@groups); 
 7869:             if (@courses_and_groups > 0) {
 7870:                 my (%allgroups,%allroles); 
 7871:                 my ($start,$end,$role,$sec,$group);
 7872:                 foreach my $envkey (%env) {
 7873:                     if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
 7874:                         my $cid = $2.'_'.$3; 
 7875:                         if ($1 eq 'gr') {
 7876:                             $group = $4;
 7877:                             $allgroups{$cid}{$group} = $env{$envkey};
 7878:                         } else {
 7879:                             if ($4 eq '') {
 7880:                                 $sec = 'none';
 7881:                             } else {
 7882:                                 $sec = $4;
 7883:                             }
 7884:                             $allroles{$cid}{$1}{$sec} = $env{$envkey};
 7885:                         }
 7886:                     } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
 7887:                         my $cid = $2.'_'.$3;
 7888:                         if ($4 eq '') {
 7889:                             $sec = 'none';
 7890:                         } else {
 7891:                             $sec = $4;
 7892:                         }
 7893:                         $allroles{$cid}{$1}{$sec} = $env{$envkey};
 7894:                     }
 7895:                 }
 7896:                 if (keys(%allroles) == 0) {
 7897:                     return;
 7898:                 }
 7899:                 foreach my $key (@courses_and_groups) {
 7900:                     my %content = %{$$access_hash{$key}};
 7901:                     my $cnum = $content{'number'};
 7902:                     my $cdom = $content{'domain'};
 7903:                     my $cid = $cdom.'_'.$cnum;
 7904:                     if (!exists($allroles{$cid})) {
 7905:                         next;
 7906:                     }    
 7907:                     foreach my $role_id (keys(%{$content{'roles'}})) {
 7908:                         my @sections = @{$content{'roles'}{$role_id}{'section'}};
 7909:                         my @groups = @{$content{'roles'}{$role_id}{'group'}};
 7910:                         my @status = @{$content{'roles'}{$role_id}{'access'}};
 7911:                         my @roles = @{$content{'roles'}{$role_id}{'role'}};
 7912:                         foreach my $role (keys(%{$allroles{$cid}})) {
 7913:                             if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
 7914:                                 foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
 7915:                                     if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
 7916:                                         if (grep/^all$/,@sections) {
 7917:                                             return 'ok';
 7918:                                         } else {
 7919:                                             if (grep/^$sec$/,@sections) {
 7920:                                                 return 'ok';
 7921:                                             }
 7922:                                         }
 7923:                                     }
 7924:                                 }
 7925:                                 if (keys(%{$allgroups{$cid}}) == 0) {
 7926:                                     if (grep/^none$/,@groups) {
 7927:                                         return 'ok';
 7928:                                     }
 7929:                                 } else {
 7930:                                     if (grep/^all$/,@groups) {
 7931:                                         return 'ok';
 7932:                                     } 
 7933:                                     foreach my $group (keys(%{$allgroups{$cid}})) {
 7934:                                         if (grep/^$group$/,@groups) {
 7935:                                             return 'ok';
 7936:                                         }
 7937:                                     }
 7938:                                 } 
 7939:                             }
 7940:                         }
 7941:                     }
 7942:                 }
 7943:             }
 7944:             if ($guest) {
 7945:                 return $guest;
 7946:             }
 7947:         }
 7948:     }
 7949:     return;
 7950: }
 7951: 
 7952: sub course_group_datechecker {
 7953:     my ($dates,$now,$status) = @_;
 7954:     my ($start,$end) = split(/\./,$dates);
 7955:     if (!$start && !$end) {
 7956:         return 'ok';
 7957:     }
 7958:     if (grep/^active$/,@{$status}) {
 7959:         if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
 7960:             return 'ok';
 7961:         }
 7962:     }
 7963:     if (grep/^previous$/,@{$status}) {
 7964:         if ($end > $now ) {
 7965:             return 'ok';
 7966:         }
 7967:     }
 7968:     if (grep/^future$/,@{$status}) {
 7969:         if ($start > $now) {
 7970:             return 'ok';
 7971:         }
 7972:     }
 7973:     return; 
 7974: }
 7975: 
 7976: sub parse_portfolio_url {
 7977:     my ($url) = @_;
 7978: 
 7979:     my ($type,$udom,$unum,$group,$file_name);
 7980:     
 7981:     if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
 7982: 	$type = 1;
 7983:         $udom = $1;
 7984:         $unum = $2;
 7985:         $file_name = $3;
 7986:     } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
 7987: 	$type = 2;
 7988:         $udom = $1;
 7989:         $unum = $2;
 7990:         $group = $3;
 7991:         $file_name = $3.'/'.$4;
 7992:     }
 7993:     if (wantarray) {
 7994: 	return ($type,$udom,$unum,$file_name,$group);
 7995:     }
 7996:     return $type;
 7997: }
 7998: 
 7999: sub is_portfolio_url {
 8000:     my ($url) = @_;
 8001:     return scalar(&parse_portfolio_url($url));
 8002: }
 8003: 
 8004: sub is_portfolio_file {
 8005:     my ($file) = @_;
 8006:     if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
 8007:         return 1;
 8008:     }
 8009:     return;
 8010: }
 8011: 
 8012: sub is_coursetool_logo {
 8013:     my ($uri) = @_;
 8014:     if ($env{'request.course.id'}) {
 8015:         my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
 8016:         if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) {
 8017:             return 1;
 8018:         }
 8019:     }
 8020:     return;
 8021: }
 8022: 
 8023: sub usertools_access {
 8024:     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
 8025:     my ($access,%tools);
 8026:     if ($context eq '') {
 8027:         $context = 'tools';
 8028:     }
 8029:     if ($context eq 'requestcourses') {
 8030:         %tools = (
 8031:                       official   => 1,
 8032:                       unofficial => 1,
 8033:                       community  => 1,
 8034:                       textbook   => 1,
 8035:                       placement  => 1,
 8036:                       lti        => 1,
 8037:                  );
 8038:     } elsif ($context eq 'requestauthor') {
 8039:         %tools = (
 8040:                       requestauthor => 1,
 8041:                  );
 8042:     } else {
 8043:         %tools = (
 8044:                       aboutme   => 1,
 8045:                       blog      => 1,
 8046:                       webdav    => 1,
 8047:                       portfolio => 1,
 8048:                       timezone  => 1,
 8049:                  );
 8050:     }
 8051:     return if (!defined($tools{$tool}));
 8052: 
 8053:     if (($udom eq '') || ($uname eq '')) {
 8054:         $udom = $env{'user.domain'};
 8055:         $uname = $env{'user.name'};
 8056:     }
 8057: 
 8058:     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
 8059:         if ($action ne 'reload') {
 8060:             if ($context eq 'requestcourses') {
 8061:                 return $env{'environment.canrequest.'.$tool};
 8062:             } elsif ($context eq 'requestauthor') {
 8063:                 return $env{'environment.canrequest.author'};
 8064:             } else {
 8065:                 return $env{'environment.availabletools.'.$tool};
 8066:             }
 8067:         }
 8068:     }
 8069: 
 8070:     my ($toolstatus,$inststatus,$envkey);
 8071:     if ($context eq 'requestauthor') {
 8072:         $envkey = $context; 
 8073:     } else {
 8074:         $envkey = $context.'.'.$tool;
 8075:     }
 8076: 
 8077:     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
 8078:          ($action ne 'reload')) {
 8079:         $toolstatus = $env{'environment.'.$envkey};
 8080:         $inststatus = $env{'environment.inststatus'};
 8081:     } else {
 8082:         if (ref($userenvref) eq 'HASH') {
 8083:             $toolstatus = $userenvref->{$envkey};
 8084:             $inststatus = $userenvref->{'inststatus'};
 8085:         } else {
 8086:             my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');
 8087:             $toolstatus = $userenv{$envkey};
 8088:             $inststatus = $userenv{'inststatus'};
 8089:         }
 8090:     }
 8091: 
 8092:     if ($toolstatus ne '') {
 8093:         if ($toolstatus) {
 8094:             $access = 1;
 8095:         } else {
 8096:             $access = 0;
 8097:         }
 8098:         return $access;
 8099:     }
 8100: 
 8101:     my ($is_adv,%domdef);
 8102:     if (ref($is_advref) eq 'HASH') {
 8103:         $is_adv = $is_advref->{'is_adv'};
 8104:     } else {
 8105:         $is_adv = &is_advanced_user($udom,$uname);
 8106:     }
 8107:     if (ref($domdefref) eq 'HASH') {
 8108:         %domdef = %{$domdefref};
 8109:     } else {
 8110:         %domdef = &get_domain_defaults($udom);
 8111:     }
 8112:     if (ref($domdef{$tool}) eq 'HASH') {
 8113:         if ($is_adv) {
 8114:             if ($domdef{$tool}{'_LC_adv'} ne '') {
 8115:                 if ($domdef{$tool}{'_LC_adv'}) { 
 8116:                     $access = 1;
 8117:                 } else {
 8118:                     $access = 0;
 8119:                 }
 8120:                 return $access;
 8121:             }
 8122:         }
 8123:         if ($inststatus ne '') {
 8124:             my ($hasaccess,$hasnoaccess);
 8125:             foreach my $affiliation (split(/:/,$inststatus)) {
 8126:                 if ($domdef{$tool}{$affiliation} ne '') { 
 8127:                     if ($domdef{$tool}{$affiliation}) {
 8128:                         $hasaccess = 1;
 8129:                     } else {
 8130:                         $hasnoaccess = 1;
 8131:                     }
 8132:                 }
 8133:             }
 8134:             if ($hasaccess || $hasnoaccess) {
 8135:                 if ($hasaccess) {
 8136:                     $access = 1;
 8137:                 } elsif ($hasnoaccess) {
 8138:                     $access = 0; 
 8139:                 }
 8140:                 return $access;
 8141:             }
 8142:         } else {
 8143:             if ($domdef{$tool}{'default'} ne '') {
 8144:                 if ($domdef{$tool}{'default'}) {
 8145:                     $access = 1;
 8146:                 } elsif ($domdef{$tool}{'default'} == 0) {
 8147:                     $access = 0;
 8148:                 }
 8149:                 return $access;
 8150:             }
 8151:         }
 8152:     } else {
 8153:         if (($context eq 'tools') && ($tool ne 'webdav')) {
 8154:             $access = 1;
 8155:         } else {
 8156:             $access = 0;
 8157:         }
 8158:         return $access;
 8159:     }
 8160: }
 8161: 
 8162: sub is_course_owner {
 8163:     my ($cdom,$cnum,$udom,$uname) = @_;
 8164:     if (($udom eq '') || ($uname eq '')) {
 8165:         $udom = $env{'user.domain'};
 8166:         $uname = $env{'user.name'};
 8167:     }
 8168:     unless (($udom eq '') || ($uname eq '')) {
 8169:         if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) {
 8170:             if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
 8171:                 return 1;
 8172:             } else {
 8173:                 my %courseinfo = &coursedescription($cdom.'/'.$cnum);
 8174:                 if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
 8175:                     return 1;
 8176:                 }
 8177:             }
 8178:         }
 8179:     }
 8180:     return;
 8181: }
 8182: 
 8183: sub is_advanced_user {
 8184:     my ($udom,$uname) = @_;
 8185:     if ($udom ne '' && $uname ne '') {
 8186:         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
 8187:             if (wantarray) {
 8188:                 return ($env{'user.adv'},$env{'user.author'});
 8189:             } else {
 8190:                 return $env{'user.adv'};
 8191:             }
 8192:         }
 8193:     }
 8194:     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
 8195:     my %allroles;
 8196:     my ($is_adv,$is_author);
 8197:     foreach my $role (keys(%roleshash)) {
 8198:         my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
 8199:         my $area = '/'.$tdomain.'/'.$trest;
 8200:         if ($sec ne '') {
 8201:             $area .= '/'.$sec;
 8202:         }
 8203:         if (($area ne '') && ($trole ne '')) {
 8204:             my $spec=$trole.'.'.$area;
 8205:             if ($trole =~ /^cr\//) {
 8206:                 &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
 8207:             } elsif ($trole ne 'gr') {
 8208:                 &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
 8209:             }
 8210:             if ($trole eq 'au') {
 8211:                 $is_author = 1;
 8212:             }
 8213:         }
 8214:     }
 8215:     foreach my $role (keys(%allroles)) {
 8216:         last if ($is_adv);
 8217:         foreach my $item (split(/:/,$allroles{$role})) {
 8218:             if ($item ne '') {
 8219:                 my ($privilege,$restrictions)=split(/&/,$item);
 8220:                 if ($privilege eq 'adv') {
 8221:                     $is_adv = 1;
 8222:                     last;
 8223:                 }
 8224:             }
 8225:         }
 8226:     }
 8227:     if (wantarray) {
 8228:         return ($is_adv,$is_author);
 8229:     }
 8230:     return $is_adv;
 8231: }
 8232: 
 8233: sub check_can_request {
 8234:     my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
 8235:     my $canreq = 0;
 8236:     if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
 8237:         $uname = $env{'user.name'};
 8238:         $udom = $env{'user.domain'};
 8239:     }
 8240:     my ($types,$typename) = &Apache::loncommon::course_types();
 8241:     my @options = ('approval','validate','autolimit');
 8242:     my $optregex = join('|',@options);
 8243:     if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
 8244:         my %willtrust;
 8245:         foreach my $type (@{$types}) {
 8246:             if (&usertools_access($uname,$udom,$type,undef,
 8247:                                   'requestcourses')) {
 8248:                 $canreq ++;
 8249:                 if (ref($request_domains) eq 'HASH') {
 8250:                     push(@{$request_domains->{$type}},$udom);
 8251:                 }
 8252:                 if ($dom eq $udom) {
 8253:                     $can_request->{$type} = 1;
 8254:                 }
 8255:             }
 8256:             if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
 8257:                 ($env{'environment.reqcrsotherdom.'.$type} ne '')) {
 8258:                 my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
 8259:                 if (@curr > 0) {
 8260:                     foreach my $item (@curr) {
 8261:                         if (ref($request_domains) eq 'HASH') {
 8262:                             my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
 8263:                             if ($otherdom ne '') {
 8264:                                 unless (exists($willtrust{$otherdom})) {
 8265:                                     $willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom);
 8266:                                 }
 8267:                                 if ($willtrust{$otherdom}) {
 8268:                                     if (ref($request_domains->{$type}) eq 'ARRAY') {
 8269:                                         unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
 8270:                                             push(@{$request_domains->{$type}},$otherdom);
 8271:                                         }
 8272:                                     } else {
 8273:                                         push(@{$request_domains->{$type}},$otherdom);
 8274:                                     }
 8275:                                 }
 8276:                             }
 8277:                         }
 8278:                     }
 8279:                     unless ($dom eq $env{'user.domain'}) {
 8280:                         $canreq ++;
 8281:                         if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
 8282:                             $can_request->{$type} = 1;
 8283:                         }
 8284:                     }
 8285:                 }
 8286:             }
 8287:         }
 8288:     }
 8289:     return $canreq;
 8290: }
 8291: 
 8292: # ---------------------------------------------- Custom access rule evaluation
 8293: 
 8294: sub customaccess {
 8295:     my ($priv,$uri)=@_;
 8296:     my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
 8297:     my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
 8298:     $udom = &LONCAPA::clean_domain($udom);
 8299:     $ucrs = &LONCAPA::clean_username($ucrs);
 8300:     my $access=0;
 8301:     foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
 8302: 	my ($effect,$realm,$role,$type)=split(/\:/,$right);
 8303: 	if ($type eq 'user') {
 8304: 	    foreach my $scope (split(/\s*\,\s*/,$realm)) {
 8305: 		my ($tdom,$tuname)=split(m{/},$scope);
 8306: 		if ($tdom) {
 8307: 		    if ($tdom ne $env{'user.domain'}) { next; }
 8308: 		}
 8309: 		if ($tuname) {
 8310: 		    if ($tuname ne $env{'user.name'}) { next; }
 8311: 		}
 8312: 		$access=($effect eq 'allow');
 8313: 		last;
 8314: 	    }
 8315: 	} else {
 8316: 	    if ($role) {
 8317: 		if ($role ne $urole) { next; }
 8318: 	    }
 8319: 	    foreach my $scope (split(/\s*\,\s*/,$realm)) {
 8320: 		my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
 8321: 		if ($tdom) {
 8322: 		    if ($tdom ne $udom) { next; }
 8323: 		}
 8324: 		if ($tcrs) {
 8325: 		    if ($tcrs ne $ucrs) { next; }
 8326: 		}
 8327: 		if ($tsec) {
 8328: 		    if ($tsec ne $usec) { next; }
 8329: 		}
 8330: 		$access=($effect eq 'allow');
 8331: 		last;
 8332: 	    }
 8333: 	    if ($realm eq '' && $role eq '') {
 8334: 		$access=($effect eq 'allow');
 8335: 	    }
 8336: 	}
 8337:     }
 8338:     return $access;
 8339: }
 8340: 
 8341: # ------------------------------------------------- Check for a user privilege
 8342: 
 8343: sub allowed {
 8344:     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;
 8345:     my $ver_orguri=$uri;
 8346:     $uri=&deversion($uri);
 8347:     my $orguri=$uri;
 8348:     $uri=&declutter($uri);
 8349: 
 8350:     if ($priv eq 'evb') {
 8351: # Evade communication block restrictions for specified role in a course or domain
 8352:         if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
 8353:             return $1;
 8354:         } else {
 8355:             return;
 8356:         }
 8357:     }
 8358: 
 8359:     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 8360: # Free bre access to adm and meta resources
 8361:     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) 
 8362: 	 || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
 8363: 	&& ($priv eq 'bre')) {
 8364: 	return 'F';
 8365:     }
 8366: 
 8367: # Free bre access to user's own portfolio contents
 8368:     my ($space,$domain,$name,@dir)=split('/',$uri);
 8369:     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
 8370: 	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
 8371:         my %setters;
 8372:         my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = 
 8373:             &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
 8374:         if (($startblock && $endblock) || ($by_ip)) {
 8375:             return 'B';
 8376:         } else {
 8377:             return 'F';
 8378:         }
 8379:     }
 8380: 
 8381: # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
 8382:     if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
 8383:          && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
 8384:         if (exists($env{'request.course.id'})) {
 8385:             my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 8386:             my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
 8387:             if (($domain eq $cdom) && ($name eq $cnum)) {
 8388:                 my $courseprivid=$env{'request.course.id'};
 8389:                 $courseprivid=~s/\_/\//;
 8390:                 if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
 8391:                     .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
 8392:                     return $1; 
 8393:                 } else {
 8394:                     if ($env{'request.course.sec'}) {
 8395:                         $courseprivid.='/'.$env{'request.course.sec'};
 8396:                     }
 8397:                     if ($env{'user.priv.'.$env{'request.role'}.'./'.
 8398:                         $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
 8399:                         return $2;
 8400:                     }
 8401:                 }
 8402:             }
 8403:         }
 8404:     }
 8405: 
 8406: # Free bre to public access
 8407: 
 8408:     if ($priv eq 'bre') {
 8409:         my $copyright;
 8410:         unless ($uri =~ /ext\.tool/) {
 8411:             $copyright=&metadata($uri,'copyright');
 8412:         }
 8413: 	if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
 8414:            return 'F'; 
 8415:         }
 8416:         if ($copyright eq 'priv') {
 8417:             $uri=~/([^\/]+)\/([^\/]+)\//;
 8418: 	    unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) {
 8419: 		return '';
 8420:             }
 8421:         }
 8422:         if ($copyright eq 'domain') {
 8423:             $uri=~/([^\/]+)\/([^\/]+)\//;
 8424: 	    unless (($env{'user.domain'} eq $1) ||
 8425:                  ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) {
 8426: 		return '';
 8427:             }
 8428:         }
 8429:         if ($env{'request.role'}=~ /li\.\//) {
 8430:             # Library role, so allow browsing of resources in this domain.
 8431:             return 'F';
 8432:         }
 8433:         if ($copyright eq 'custom') {
 8434: 	    unless (&customaccess($priv,$uri)) { return ''; }
 8435:         }
 8436:     }
 8437:     # Domain coordinator is trying to create a course
 8438:     if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
 8439:         # uri is the requested domain in this case.
 8440:         # comparison to 'request.role.domain' shows if the user has selected
 8441:         # a role of dc for the domain in question.
 8442:         return 'F' if ($uri eq $env{'request.role.domain'});
 8443:     }
 8444: 
 8445:     my $thisallowed='';
 8446:     my $statecond=0;
 8447:     my $courseprivid='';
 8448: 
 8449:     my $ownaccess;
 8450:     # Community Coordinator or Assistant Co-author browsing resource space.
 8451:     if (($priv eq 'bro') && ($env{'user.author'})) {
 8452:         if ($uri eq '') {
 8453:             $ownaccess = 1;
 8454:         } else {
 8455:             if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
 8456:                 my $udom = $env{'user.domain'};
 8457:                 my $uname = $env{'user.name'};
 8458:                 if ($uri =~ m{^\Q$udom\E/?$}) {
 8459:                     $ownaccess = 1;
 8460:                 } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) {
 8461:                     unless ($uri =~ m{\.\./}) {
 8462:                         $ownaccess = 1;
 8463:                     }
 8464:                 } elsif (($udom ne 'public') && ($uname ne 'public')) {
 8465:                     my $now = time;
 8466:                     if ($uri =~ m{^([^/]+)/?$}) {
 8467:                         my $adom = $1;
 8468:                         foreach my $key (keys(%env)) {
 8469:                             if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
 8470:                                 my ($start,$end) = split(/\./,$env{$key});
 8471:                                 if (($now >= $start) && (!$end || $end > $now)) {
 8472:                                     $ownaccess = 1;
 8473:                                     last;
 8474:                                 }
 8475:                             }
 8476:                         }
 8477:                     } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) {
 8478:                         my $adom = $1;
 8479:                         my $aname = $2;
 8480:                         foreach my $role ('ca','aa') { 
 8481:                             if ($env{"user.role.$role./$adom/$aname"}) {
 8482:                                 my ($start,$end) =
 8483:                                     split(/\./,$env{"user.role.$role./$adom/$aname"});
 8484:                                 if (($now >= $start) && (!$end || $end > $now)) {
 8485:                                     $ownaccess = 1;
 8486:                                     last;
 8487:                                 }
 8488:                             }
 8489:                         }
 8490:                     }
 8491:                 }
 8492:             }
 8493:         }
 8494:     }
 8495: 
 8496: # Course
 8497: 
 8498:     if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
 8499:         unless (($priv eq 'bro') && (!$ownaccess)) {
 8500:             $thisallowed.=$1;
 8501:         }
 8502:     }
 8503: 
 8504: # Domain
 8505: 
 8506:     if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
 8507:        =~/\Q$priv\E\&([^\:]*)/) {
 8508:         unless (($priv eq 'bro') && (!$ownaccess)) {
 8509:             $thisallowed.=$1;
 8510:         }
 8511:     }
 8512: 
 8513: # User who is not author or co-author might still be able to edit
 8514: # resource of an author in the domain (e.g., if Domain Coordinator).
 8515:     if (($priv eq 'eco') && ($thisallowed eq '') && ($env{'request.course.id'}) &&
 8516:         (&allowed('mdc',$env{'request.course.id'}))) {
 8517:         if ($env{"user.priv.cm./$uri/"}=~/\Q$priv\E\&([^\:]*)/) {
 8518:             $thisallowed.=$1;
 8519:         }
 8520:     }
 8521: 
 8522: # Course: uri itself is a course
 8523:     my $courseuri=$uri;
 8524:     $courseuri=~s/\_(\d)/\/$1/;
 8525:     $courseuri=~s/^([^\/])/\/$1/;
 8526: 
 8527:     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
 8528:        =~/\Q$priv\E\&([^\:]*)/) {
 8529:         if ($priv eq 'mip') {
 8530:             my $rem = $1;
 8531:             if (($uri ne '') && ($env{'request.course.id'} eq $uri) &&
 8532:                 ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) {
 8533:                 my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 8534:                 if ($cdom ne '') {
 8535:                     my %passwdconf = &get_passwdconf($cdom);
 8536:                     if (ref($passwdconf{'crsownerchg'}) eq 'HASH') {
 8537:                         if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') {
 8538:                             if (@{$passwdconf{'crsownerchg'}{'by'}}) {
 8539:                                 my @inststatuses = split(':',$env{'environment.inststatus'});
 8540:                                 unless (@inststatuses) {
 8541:                                     @inststatuses = ('default');
 8542:                                 }
 8543:                                 foreach my $status (@inststatuses) {
 8544:                                     if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) {
 8545:                                         $thisallowed.=$rem;
 8546:                                     }
 8547:                                 }
 8548:                             }
 8549:                         }
 8550:                     }
 8551:                 }
 8552:             }
 8553:         } else {
 8554:             unless (($priv eq 'bro') && (!$ownaccess)) {
 8555:                 $thisallowed.=$1;
 8556:             }
 8557:         }
 8558:     }
 8559: 
 8560: # URI is an uploaded document for this course, default permissions don't matter
 8561: # not allowing 'edit' access (editupload) to uploaded course docs
 8562:     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
 8563: 	$thisallowed='';
 8564:         my ($match)=&is_on_map($uri);
 8565:         if ($match) {
 8566:             if ($env{'user.priv.'.$env{'request.role'}.'./'}
 8567:                   =~/\Q$priv\E\&([^\:]*)/) {
 8568:                 my $value = $1;
 8569:                 my $deeplinkblock;
 8570:                 unless ($nodeeplinkcheck) {
 8571:                     $deeplinkblock = &deeplink_check($priv,$symb,$uri);
 8572:                 }
 8573:                 if ($deeplinkblock) {
 8574:                     $thisallowed='D';
 8575:                 } elsif ($noblockcheck) {
 8576:                     $thisallowed.=$value;
 8577:                 } else {
 8578:                     my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
 8579:                     if (@blockers > 0) {
 8580:                         $thisallowed = 'B';
 8581:                     } else {
 8582:                         $thisallowed.=$value;
 8583:                     }
 8584:                 }
 8585:             }
 8586:         } else {
 8587:             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
 8588:             if ($refuri) {
 8589:                 if ($refuri =~ m|^/adm/|) {
 8590:                     $thisallowed='F';
 8591:                 } else {
 8592:                     $refuri=&declutter($refuri);
 8593:                     my ($match) = &is_on_map($refuri);
 8594:                     if ($match) {
 8595:                         my $deeplinkblock;
 8596:                         unless ($nodeeplinkcheck) {
 8597:                             $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
 8598:                         }
 8599:                         if ($deeplinkblock) {
 8600:                             $thisallowed='D';
 8601:                         } elsif ($noblockcheck) {
 8602:                             $thisallowed='F';
 8603:                         } else {
 8604:                             my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
 8605:                             if (@blockers > 0) {
 8606:                                 $thisallowed = 'B';
 8607:                             } else {
 8608:                                 $thisallowed='F';
 8609:                             }
 8610:                         }
 8611:                     }
 8612:                 }
 8613:             }
 8614:         }
 8615:     }
 8616: 
 8617:     if ($priv eq 'bre'
 8618: 	&& $thisallowed ne 'F' 
 8619: 	&& $thisallowed ne '2'
 8620: 	&& &is_portfolio_url($uri)) {
 8621: 	$thisallowed = &portfolio_access($uri,$clientip);
 8622:     }
 8623: 
 8624: # Full access at system, domain or course-wide level? Exit.
 8625:     if ($thisallowed=~/F/) {
 8626: 	return 'F';
 8627:     }
 8628: 
 8629: # If this is generating or modifying users, exit with special codes
 8630: 
 8631:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
 8632: 	if (($priv eq 'cca') || ($priv eq 'caa')) {
 8633: 	    my ($audom,$auname)=split('/',$uri);
 8634: # no author name given, so this just checks on the general right to make a co-author in this domain
 8635: 	    unless ($auname) { return $thisallowed; }
 8636: # an author name is given, so we are about to actually make a co-author for a certain account
 8637: 	    if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
 8638: 		(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
 8639: 		 ($audom ne $env{'request.role.domain'}))) { return ''; }
 8640: 	}
 8641: 	return $thisallowed;
 8642:     }
 8643: #
 8644: # Gathered so far: system, domain and course wide privileges
 8645: #
 8646: # Course: See if uri or referer is an individual resource that is part of 
 8647: # the course
 8648: 
 8649:     if ($env{'request.course.id'}) {
 8650: 
 8651:         if ($priv eq 'bre') {
 8652:             if (&is_coursetool_logo($uri)) {
 8653:                 return 'F';
 8654:             }
 8655:         }
 8656: 
 8657: # If this is modifying password (internal auth) domains must match for user and user's role.
 8658: 
 8659:         if ($priv eq 'mip') {
 8660:             if ($env{'user.domain'} eq $env{'request.role.domain'}) {
 8661:                 return $thisallowed;
 8662:             } else {
 8663:                 return '';
 8664:             }
 8665:         }
 8666: 
 8667:        $courseprivid=$env{'request.course.id'};
 8668:        if ($env{'request.course.sec'}) {
 8669:           $courseprivid.='/'.$env{'request.course.sec'};
 8670:        }
 8671:        $courseprivid=~s/\_/\//;
 8672:        my $checkreferer=1;
 8673:        my ($match,$cond)=&is_on_map($uri);
 8674:        if ($match) {
 8675:            $statecond=$cond;
 8676:            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
 8677:                =~/\Q$priv\E\&([^\:]*)/) {
 8678:                my $value = $1;
 8679:                if ($priv eq 'bre') {
 8680:                    my $deeplinkblock;
 8681:                    unless ($nodeeplinkcheck) {
 8682:                        $deeplinkblock = &deeplink_check($priv,$symb,$uri);
 8683:                    }
 8684:                    if ($deeplinkblock) {
 8685:                        $thisallowed = 'D';
 8686:                    } elsif ($noblockcheck) {
 8687:                        $thisallowed.=$value;
 8688:                    } else {
 8689:                        my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
 8690:                        if (@blockers > 0) {
 8691:                            $thisallowed = 'B';
 8692:                        } else {
 8693:                            $thisallowed.=$value;
 8694:                        }
 8695:                    }
 8696:                } else {
 8697:                    $thisallowed.=$value;
 8698:                }
 8699:                $checkreferer=0;
 8700:            }
 8701:        }
 8702: 
 8703:        if ($checkreferer) {
 8704: 	  my $refuri=$env{'httpref.'.$orguri};
 8705:             unless ($refuri) {
 8706:                 foreach my $key (keys(%env)) {
 8707: 		    if ($key=~/^httpref\..*\*/) {
 8708: 			my $pattern=$key;
 8709:                         $pattern=~s/^httpref\.\/res\///;
 8710:                         $pattern=~s/\*/\[\^\/\]\+/g;
 8711:                         $pattern=~s/\//\\\//g;
 8712:                         if ($orguri=~/$pattern/) {
 8713: 			    $refuri=$env{$key};
 8714:                         }
 8715:                     }
 8716:                 }
 8717:             }
 8718: 
 8719:          if ($refuri) { 
 8720: 	  $refuri=&declutter($refuri);
 8721:           my ($match,$cond)=&is_on_map($refuri);
 8722:             if ($match) {
 8723:               my $refstatecond=$cond;
 8724:               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
 8725:                   =~/\Q$priv\E\&([^\:]*)/) {
 8726:                   my $value = $1;
 8727:                   if ($priv eq 'bre') {
 8728:                       my $deeplinkblock;
 8729:                       unless ($nodeeplinkcheck) {
 8730:                           $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
 8731:                       }
 8732:                       if ($deeplinkblock) {
 8733:                           $thisallowed = 'D';
 8734:                       } elsif ($noblockcheck) {
 8735:                           $thisallowed.=$value;
 8736:                       } else {
 8737:                           my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
 8738:                           if (@blockers > 0) {
 8739:                               $thisallowed = 'B';
 8740:                           } else {
 8741:                               $thisallowed.=$value;
 8742:                           }
 8743:                       }
 8744:                   } else {
 8745:                       $thisallowed.=$value;
 8746:                   }
 8747:                   $uri=$refuri;
 8748:                   $statecond=$refstatecond;
 8749:               }
 8750:           }
 8751:         }
 8752:        }
 8753:    }
 8754: 
 8755: #
 8756: # Gathered now: all privileges that could apply, and condition number
 8757: # 
 8758: #
 8759: # Full or no access?
 8760: #
 8761: 
 8762:     if ($thisallowed=~/F/) {
 8763: 	return 'F';
 8764:     }
 8765: 
 8766:     unless ($thisallowed) {
 8767:         return '';
 8768:     }
 8769: 
 8770: # Restrictions exist, deal with them
 8771: #
 8772: #   C:according to course preferences
 8773: #   R:according to resource settings
 8774: #   L:unless locked
 8775: #   X:according to user session state
 8776: #
 8777: 
 8778: # Possibly locked functionality, check all courses
 8779: # In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
 8780: # Locks might take effect only after 10 minutes cache expiration for other
 8781: # courses, and 2 minutes for current course, in which user has st or ta role
 8782: # which is neither expired nor a future role (unless current course).
 8783: 
 8784:     my ($needlockcheck,$now,$crsonly);
 8785:     if ($thisallowed=~/L/) {
 8786:         $now = time;
 8787:         if ($priv eq 'bre') {
 8788:             if ($uri ne '') {
 8789:                 if ($orguri =~ m{^/+res/}) {
 8790:                     if ($uri =~ m{^lib/templates/}) {
 8791:                         if ($env{'request.course.id'}) {
 8792:                             $crsonly = 1;
 8793:                             $needlockcheck = 1;
 8794:                         }
 8795:                     } else {
 8796:                         $needlockcheck = 1;
 8797:                     }
 8798:                 } elsif ($env{'request.course.id'}) {
 8799:                     my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
 8800:                     if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) ||
 8801:                         ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) {
 8802:                         $crsonly = 1;
 8803:                     }
 8804:                     $needlockcheck = 1;
 8805:                 }
 8806:             }
 8807:         } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) {
 8808:             $needlockcheck = 1;
 8809:         }
 8810:     }
 8811:     if ($needlockcheck) {
 8812:         foreach my $envkey (keys(%env)) {
 8813:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
 8814:                my $courseid=$2;
 8815:                my $roleid=$1.'.'.$2;
 8816:                $courseid=~s/^\///;
 8817:                unless ($env{'request.role'} eq $roleid) {
 8818:                    my ($start,$end) = split(/\./,$env{$envkey});
 8819:                    next unless (($now >= $start) && (!$end || $end > $now));
 8820:                }
 8821:                my $expiretime=600;
 8822:                if ($env{'request.role'} eq $roleid) {
 8823: 		  $expiretime=120;
 8824:                }
 8825: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
 8826:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
 8827:                if ((time-$env{$prefix.'last_cache'})>$expiretime) {
 8828: 		   &coursedescription($courseid,{'freshen_cache' => 1});
 8829:                }
 8830:                if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
 8831:                 || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
 8832: 		   if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) {
 8833:                        &log($env{'user.domain'},$env{'user.name'},
 8834:                             $env{'user.home'},
 8835:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
 8836:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
 8837:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
 8838: 		       return '';
 8839:                    }
 8840:                }
 8841:                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
 8842:                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
 8843: 		   if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
 8844:                        &log($env{'user.domain'},$env{'user.name'},
 8845:                             $env{'user.home'},
 8846:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
 8847:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
 8848:                             $env{$prefix.'priv.'.$priv.'.lock.expire'});
 8849: 		       return '';
 8850:                    }
 8851:                }
 8852: 	   }
 8853:        }
 8854:     }
 8855: 
 8856: #
 8857: # Rest of the restrictions depend on selected course
 8858: #
 8859: 
 8860:     unless ($env{'request.course.id'}) {
 8861: 	if ($thisallowed eq 'A') {
 8862: 	    return 'A';
 8863:         } elsif ($thisallowed eq 'B') {
 8864:             return 'B';
 8865: 	} else {
 8866: 	    return '1';
 8867: 	}
 8868:     }
 8869: 
 8870: #
 8871: # Now user is definitely in a course
 8872: #
 8873: 
 8874: 
 8875: # Course preferences
 8876: 
 8877:    if ($thisallowed=~/C/) {
 8878:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
 8879:        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
 8880:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
 8881: 	   =~/\Q$rolecode\E/) {
 8882: 	   if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
 8883: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
 8884: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
 8885: 			$env{'request.course.id'});
 8886: 	   }
 8887:            return '';
 8888:        }
 8889: 
 8890:        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
 8891: 	   =~/\Q$unamedom\E/) {
 8892: 	   if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
 8893: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
 8894: 			'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
 8895: 			$env{'request.course.id'});
 8896: 	   }
 8897:            return '';
 8898:        }
 8899:    }
 8900: 
 8901: # Resource preferences
 8902: 
 8903:    if ($thisallowed=~/R/) {
 8904:        my $rolecode=(split(/\./,$env{'request.role'}))[0];
 8905:        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
 8906: 	   if (($priv ne 'pch') && ($priv ne 'plc')) { 
 8907: 	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
 8908: 			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
 8909: 	   }
 8910: 	   return '';
 8911:        }
 8912:    }
 8913: 
 8914: # Restricted for deeplinked session?
 8915: 
 8916:     if ($env{'request.deeplink.login'}) {
 8917:         if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {
 8918:             if (!$symb) { $symb=&symbread($uri,1); }
 8919:             if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {
 8920:                 return '';
 8921:             }
 8922:         }
 8923:     }
 8924: 
 8925: # Restricted by state or randomout?
 8926: 
 8927:    if ($thisallowed=~/X/) {
 8928:       if ($env{'acc.randomout'}) {
 8929: 	 if (!$symb) { $symb=&symbread($uri,1); }
 8930:          if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
 8931:             return ''; 
 8932:          }
 8933:       }
 8934:       if (&condval($statecond)) {
 8935: 	 return '2';
 8936:       } else {
 8937:          return '';
 8938:       }
 8939:    }
 8940: 
 8941:     if ($thisallowed eq 'A') {
 8942: 	return 'A';
 8943:     } elsif ($thisallowed eq 'B') {
 8944:         return 'B';
 8945:     } elsif ($thisallowed eq 'D') {
 8946:         return 'D';
 8947:     }
 8948:    return 'F';
 8949: }
 8950: 
 8951: # ------------------------------------------- Check construction space access
 8952: 
 8953: sub constructaccess {
 8954:     my ($url,$setpriv)=@_;
 8955: 
 8956: # We do not allow editing of previous versions of files
 8957:     if ($url=~/\.(\d+)\.(\w+)$/) { return ''; }
 8958: 
 8959: # Get username and domain from URL
 8960:     my ($ownername,$ownerdomain,$ownerhome);
 8961: 
 8962:     ($ownerdomain,$ownername) =
 8963:         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)});
 8964: 
 8965: # The URL does not really point to any authorspace, forget it
 8966:     unless (($ownername) && ($ownerdomain)) { return ''; }
 8967: 
 8968: # Now we need to see if the user has access to the authorspace of
 8969: # $ownername at $ownerdomain
 8970: 
 8971:     if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) {
 8972: # Real author for this?
 8973:        $ownerhome = $env{'user.home'};
 8974:        if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
 8975:           return ($ownername,$ownerdomain,$ownerhome);
 8976:        }
 8977:     } elsif (&is_course($ownerdomain,$ownername)) {
 8978: # Course Authoring Space?
 8979:         if ($env{'request.course.id'}) {
 8980:             if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
 8981:                 ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
 8982:                 if (&allowed('mdc',$env{'request.course.id'})) {
 8983:                     $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
 8984:                     return ($ownername,$ownerdomain,$ownerhome);
 8985:                 }
 8986:             }
 8987:         }
 8988:         return '';
 8989:     } else {
 8990: # Co-author for this?
 8991:         if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
 8992:             exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
 8993:             $ownerhome = &homeserver($ownername,$ownerdomain);
 8994:             return ($ownername,$ownerdomain,$ownerhome);
 8995:         }
 8996:     }
 8997: 
 8998: # We don't have any access right now. If we are not possibly going to do anything about this,
 8999: # we might as well leave
 9000:    unless ($setpriv) { return ''; }
 9001: 
 9002: # Backdoor access?
 9003:     my $allowed=&allowed('eco',$ownerdomain);
 9004: # Nope
 9005:     unless ($allowed) { return ''; }
 9006: # Looks like we may have access, but could be locked by the owner of the construction space
 9007:     if ($allowed eq 'U') {
 9008:         my %blocked=&get('environment',['domcoord.author'],
 9009:                          $ownerdomain,$ownername);
 9010: # Is blocked by owner
 9011:         if ($blocked{'domcoord.author'} eq 'blocked') { return ''; }
 9012:     }
 9013:     if (($allowed eq 'F') || ($allowed eq 'U')) {
 9014: # Grant temporary access
 9015:         my $then=$env{'user.login.time'};
 9016:         my $update=$env{'user.update.time'};
 9017:         if (!$update) { $update = $then; }
 9018:         my $refresh=$env{'user.refresh.time'};
 9019:         if (!$refresh) { $refresh = $update; }
 9020:         my $now = time;
 9021:         &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh,
 9022:                            $now,'ca','constructaccess');
 9023:         $ownerhome = &homeserver($ownername,$ownerdomain);
 9024:         return($ownername,$ownerdomain,$ownerhome);
 9025:     }
 9026: # No business here
 9027:     return '';
 9028: }
 9029: 
 9030: # ----------------------------------------------------------- Content Blocking
 9031: 
 9032: {
 9033: # Caches for faster Course Contents display where content blocking
 9034: # is in operation (i.e., interval param set) for timed quiz.
 9035: #
 9036: # User for whom data are being temporarily cached.
 9037: my $cacheduser='';
 9038: # Course for which data are being temporarily cached.
 9039: my $cachedcid='';
 9040: # Cached blockers for this user (a hash of blocking items). 
 9041: my %cachedblockers=();
 9042: # When the data were last cached.
 9043: my $cachedlast='';
 9044: 
 9045: sub load_all_blockers {
 9046:     my ($uname,$udom)=@_;
 9047:     if (($uname ne '') && ($udom ne '')) { 
 9048:         if (($cacheduser eq $uname.':'.$udom) &&
 9049:             ($cachedcid eq $env{'request.course.id'}) &&
 9050:             (abs($cachedlast-time)<5)) {
 9051:             return;
 9052:         }
 9053:     }
 9054:     $cachedlast=time;
 9055:     $cacheduser=$uname.':'.$udom;
 9056:     $cachedcid=$env{'request.course.id'};
 9057:     %cachedblockers = &get_commblock_resources();
 9058:     return;
 9059: }
 9060: 
 9061: sub get_comm_blocks {
 9062:     my ($cdom,$cnum) = @_;
 9063:     if ($cdom eq '' || $cnum eq '') {
 9064:         return unless ($env{'request.course.id'});
 9065:         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
 9066:         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 9067:     }
 9068:     my %commblocks;
 9069:     my $hashid=$cdom.'_'.$cnum;
 9070:     my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
 9071:     if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
 9072:         %commblocks = %{$blocksref};
 9073:     } else {
 9074:         %commblocks = &dump('comm_block',$cdom,$cnum);
 9075:         my $cachetime = 600;
 9076:         &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
 9077:     }
 9078:     return %commblocks;
 9079: }
 9080: 
 9081: sub get_commblock_resources {
 9082:     my ($blocks) = @_;
 9083:     my %blockers = ();
 9084:     return %blockers unless ($env{'request.course.id'});
 9085:     my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
 9086:     if ($env{'request.course.sec'}) {
 9087:         $courseurl .= '/'.$env{'request.course.sec'};
 9088:     }
 9089:     return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
 9090:     my %commblocks;
 9091:     if (ref($blocks) eq 'HASH') {
 9092:         %commblocks = %{$blocks};
 9093:     } else {
 9094:         %commblocks = &get_comm_blocks();
 9095:     }
 9096:     return %blockers unless (keys(%commblocks) > 0); 
 9097:     my $navmap = Apache::lonnavmaps::navmap->new();
 9098:     return %blockers unless (ref($navmap));
 9099:     my $now = time;
 9100:     foreach my $block (keys(%commblocks)) {
 9101:         if ($block =~ /^(\d+)____(\d+)$/) {
 9102:             my ($start,$end) = ($1,$2);
 9103:             if ($start <= $now && $end >= $now) {
 9104:                 if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
 9105:                     if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
 9106:                         if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
 9107:                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
 9108:                                 $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; 
 9109:                             }
 9110:                         }
 9111:                         if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
 9112:                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
 9113:                                 $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
 9114:                             }
 9115:                         }
 9116:                     }
 9117:                 }
 9118:             }
 9119:         } elsif ($block =~ /^firstaccess____(.+)$/) {
 9120:             my $item = $1;
 9121:             if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
 9122:                 if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
 9123:                     my (@interval,$mapname);
 9124:                     my $type = 'map';
 9125:                     if ($item eq 'course') {
 9126:                         $type = 'course';
 9127:                         @interval=&EXT("resource.0.interval");
 9128:                     } else {
 9129:                         if ($item =~ /___\d+___/) {
 9130:                             $type = 'resource';
 9131:                             @interval=&EXT("resource.0.interval",$item);
 9132:                         } else {
 9133:                             $mapname = &deversion($item);
 9134:                             if (ref($navmap)) {
 9135:                                 my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
 9136:                                 @interval = ($timelimit,'map');
 9137:                             }
 9138:                         }
 9139:                     }
 9140:                     if ($interval[0] =~ /^(\d+)/) {
 9141:                         my $timelimit = $1; 
 9142:                         my $first_access;
 9143:                         if ($type eq 'resource') {
 9144:                             $first_access=&get_first_access($interval[1],$item);
 9145:                         } elsif ($type eq 'map') {
 9146:                             $first_access=&get_first_access($interval[1],undef,$item);
 9147:                         } else {
 9148:                             $first_access=&get_first_access($interval[1]);
 9149:                         }
 9150:                         if ($first_access) {
 9151:                             my $timesup = $first_access+$timelimit;
 9152:                             if ($timesup > $now) {
 9153:                                 my $activeblock;
 9154:                                 if ($type eq 'resource') {
 9155:                                     if (ref($navmap)) {
 9156:                                         my $res = $navmap->getBySymb($item);
 9157:                                         if ($res->answerable()) {
 9158:                                             $activeblock = 1;
 9159:                                         }
 9160:                                     }
 9161:                                 } elsif ($type eq 'map') {
 9162:                                     my $mapsymb = &symbread($mapname,1);
 9163:                                     if (($mapsymb) && (ref($navmap))) {
 9164:                                         my $mapres = $navmap->getBySymb($mapsymb);
 9165:                                         if (ref($mapres)) {
 9166:                                             my $first = $mapres->map_start();
 9167:                                             my $finish = $mapres->map_finish();
 9168:                                             my $it = $navmap->getIterator($first,$finish,undef,0,0);
 9169:                                             if (ref($it)) {
 9170:                                                 my $res;
 9171:                                                 while ($res = $it->next(undef,1)) {
 9172:                                                     next unless (ref($res));
 9173:                                                     my $symb = $res->symb();
 9174:                                                     next if (($symb eq $mapsymb) || ($symb eq ''));
 9175:                                                     @interval=&EXT("resource.0.interval",$symb);
 9176:                                                     if ($interval[1] eq 'map') {
 9177:                                                         if ($res->answerable()) {
 9178:                                                             $activeblock = 1;
 9179:                                                             last;
 9180:                                                         }
 9181:                                                     }
 9182:                                                 }
 9183:                                             }
 9184:                                         }
 9185:                                     }
 9186:                                 }
 9187:                                 if ($activeblock) {
 9188:                                     if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
 9189:                                          if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
 9190:                                              $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
 9191:                                          }
 9192:                                     }
 9193:                                     if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
 9194:                                         if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
 9195:                                             $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
 9196:                                         }
 9197:                                     }
 9198:                                 }
 9199:                             }
 9200:                         }
 9201:                     }
 9202:                 }
 9203:             }
 9204:         }
 9205:     }
 9206:     return %blockers;
 9207: }
 9208: 
 9209: sub has_comm_blocking {
 9210:     my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
 9211:     my @blockers;
 9212:     return unless ($env{'request.course.id'});
 9213:     return unless ($priv eq 'bre');
 9214:     return if ($env{'request.state'} eq 'construct');
 9215:     my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
 9216:     if ($env{'request.course.sec'}) {
 9217:         $courseurl .= '/'.$env{'request.course.sec'};
 9218:     }
 9219:     return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
 9220:     my %blockinfo;
 9221:     if (ref($blocks) eq 'HASH') {
 9222:         %blockinfo = &get_commblock_resources($blocks);
 9223:     } else {
 9224:         &load_all_blockers($env{'user.name'},$env{'user.domain'});
 9225:         %blockinfo = %cachedblockers;
 9226:     }
 9227:     return unless (keys(%blockinfo) > 0);
 9228:     my (%possibles,@symbs);
 9229:     if (!$symb) {
 9230:         $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
 9231:     }
 9232:     if ($symb) {
 9233:         @symbs = ($symb);
 9234:     } elsif (keys(%possibles)) { 
 9235:         @symbs = keys(%possibles);
 9236:     }
 9237:     my $noblock;
 9238:     foreach my $symb (@symbs) {
 9239:         last if ($noblock);
 9240:         my ($map,$resid,$resurl)=&decode_symb($symb);
 9241:         foreach my $block (keys(%blockinfo)) {
 9242:             if ($block =~ /^firstaccess____(.+)$/) {
 9243:                 my $item = $1;
 9244:                 unless ($blocked) {
 9245:                     if (($item eq $map) || ($item eq $symb)) {
 9246:                         $noblock = 1;
 9247:                         last;
 9248:                     }
 9249:                 }
 9250:             }
 9251:             if (ref($blockinfo{$block}) eq 'HASH') {
 9252:                 if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
 9253:                     if ($blockinfo{$block}{'resources'}{$symb}) {
 9254:                         unless (grep(/^\Q$block\E$/,@blockers)) {
 9255:                             push(@blockers,$block);
 9256:                         }
 9257:                     }
 9258:                 }
 9259:                 if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
 9260:                     if ($blockinfo{$block}{'maps'}{$map}) {
 9261:                         unless (grep(/^\Q$block\E$/,@blockers)) {
 9262:                             push(@blockers,$block);
 9263:                         }
 9264:                     }
 9265:                 }
 9266:             }
 9267:         }
 9268:     }
 9269:     unless ($noblock) { 
 9270:         return @blockers;
 9271:     }
 9272:     return;
 9273: }
 9274: }
 9275: 
 9276: sub deeplink_check {
 9277:     my ($priv,$symb,$uri) = @_;
 9278:     return unless ($env{'request.course.id'});
 9279:     return unless ($priv eq 'bre');
 9280:     return if ($env{'request.state'} eq 'construct');
 9281:     return if ($env{'request.role.adv'});
 9282:     my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
 9283:     my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
 9284:     my (%possibles,@symbs);
 9285:     if (!$symb) {
 9286:         $symb = &symbread($uri,1,1,1,\%possibles);
 9287:     }
 9288:     if ($symb) {
 9289:         @symbs = ($symb);
 9290:     } elsif (keys(%possibles)) {
 9291:         @symbs = keys(%possibles);
 9292:     }
 9293: 
 9294:     my ($deeplink_symb,$allow);
 9295:     if ($env{'request.deeplink.login'}) {
 9296:         $deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
 9297:     }
 9298:     foreach my $symb (@symbs) {
 9299:         last if ($allow);
 9300:         my $deeplink = &EXT("resource.0.deeplink",$symb);
 9301:         if ($deeplink eq '') {
 9302:             $allow = 1;
 9303:         } else {
 9304:             my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
 9305:             if ($state ne 'only') {
 9306:                 $allow = 1;
 9307:             } else {
 9308:                 my $check_deeplink_entry;
 9309:                 if ($protect ne 'none') {
 9310:                     my ($acctype,$item) = split(/:/,$protect);
 9311:                     if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) {
 9312:                         if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) {
 9313:                             $check_deeplink_entry = 1
 9314:                         }
 9315:                     } elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) {
 9316:                         if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) {
 9317:                             $check_deeplink_entry = 1;
 9318:                         }
 9319:                     } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
 9320:                         if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
 9321:                             $check_deeplink_entry = 1;
 9322:                         }
 9323:                     }
 9324:                 }
 9325:                 if (($protect eq 'none') || ($check_deeplink_entry)) {
 9326:                     if ($scope eq 'res') {
 9327:                         if ($symb eq $deeplink_symb) {
 9328:                             $allow = 1;
 9329:                         }
 9330:                     } elsif (($scope eq 'map') || ($scope eq 'rec')) {
 9331:                         my ($map_from_symb,$map_from_login);
 9332:                         $map_from_symb = &deversion((&decode_symb($symb))[0]);
 9333:                         if ($deeplink_symb =~ /\.(page|sequence)$/) {
 9334:                             $map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
 9335:                         } else {
 9336:                             $map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
 9337:                         }
 9338:                         if (($map_from_symb) && ($map_from_login)) {
 9339:                             if ($map_from_symb eq $map_from_login) {
 9340:                                 $allow = 1;
 9341:                             } elsif ($scope eq 'rec') {
 9342:                                 my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
 9343:                                 if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
 9344:                                     $allow = 1;
 9345:                                 }
 9346:                             }
 9347:                         }
 9348:                     }
 9349:                 }
 9350:             }
 9351:         }
 9352:     }
 9353:     return if ($allow);
 9354:     return 1;
 9355: }
 9356: 
 9357: # -------------------------------- Deversion and split uri into path an filename   
 9358: 
 9359: #
 9360: #   Removes the version from a URI and
 9361: #   splits it in to its filename and path to the filename.
 9362: #   Seems like File::Basename could have done this more clearly.
 9363: #   Parameters:
 9364: #      $uri   - input URI
 9365: #   Returns:
 9366: #     Two element list consisting of 
 9367: #     $pathname  - the URI up to and excluding the trailing /
 9368: #     $filename  - The part of the URI following the last /
 9369: #  NOTE:
 9370: #    Another realization of this is simply:
 9371: #    use File::Basename;
 9372: #    ...
 9373: #    $uri = shift;
 9374: #    $filename = basename($uri);
 9375: #    $path     = dirname($uri);
 9376: #    return ($filename, $path);
 9377: #
 9378: #     The implementation below is probably faster however.
 9379: #
 9380: sub split_uri_for_cond {
 9381:     my $uri=&deversion(&declutter(shift));
 9382:     my @uriparts=split(/\//,$uri);
 9383:     my $filename=pop(@uriparts);
 9384:     my $pathname=join('/',@uriparts);
 9385:     return ($pathname,$filename);
 9386: }
 9387: # --------------------------------------------------- Is a resource on the map?
 9388: 
 9389: sub is_on_map {
 9390:     my ($pathname,$filename) = &split_uri_for_cond(shift);
 9391:     #Trying to find the conditional for the file
 9392:     my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
 9393: 	       /\&\Q$filename\E\:([\d\|]+)\&/);
 9394:     if ($match) {
 9395: 	return (1,$1);
 9396:     } else {
 9397: 	return (0,0);
 9398:     }
 9399: }
 9400: 
 9401: # --------------------------------------------------------- Get symb from alias
 9402: 
 9403: sub get_symb_from_alias {
 9404:     my $symb=shift;
 9405:     my ($map,$resid,$url)=&decode_symb($symb);
 9406: # Already is a symb
 9407:     if ($url) { return $symb; }
 9408: # Must be an alias
 9409:     my $aliassymb='';
 9410:     my %bighash;
 9411:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
 9412:                             &GDBM_READER(),0640)) {
 9413:         my $rid=$bighash{'mapalias_'.$symb};
 9414: 	if ($rid) {
 9415: 	    my ($mapid,$resid)=split(/\./,$rid);
 9416: 	    $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
 9417: 				    $resid,$bighash{'src_'.$rid});
 9418: 	}
 9419:         untie %bighash;
 9420:     }
 9421:     return $aliassymb;
 9422: }
 9423: 
 9424: # ----------------------------------------------------------------- Define Role
 9425: 
 9426: sub definerole {
 9427:   if (allowed('mcr','/')) {
 9428:     my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_;
 9429:     foreach my $role (split(':',$sysrole)) {
 9430: 	my ($crole,$cqual)=split(/\&/,$role);
 9431:         if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
 9432:         if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
 9433: 	    if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
 9434:                return "refused:s:$crole&$cqual"; 
 9435:             }
 9436:         }
 9437:     }
 9438:     foreach my $role (split(':',$domrole)) {
 9439: 	my ($crole,$cqual)=split(/\&/,$role);
 9440:         if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
 9441:         if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
 9442: 	    if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 
 9443:                return "refused:d:$crole&$cqual"; 
 9444:             }
 9445:         }
 9446:     }
 9447:     foreach my $role (split(':',$courole)) {
 9448: 	my ($crole,$cqual)=split(/\&/,$role);
 9449:         if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
 9450:         if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
 9451: 	    if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
 9452:                return "refused:c:$crole&$cqual"; 
 9453:             }
 9454:         }
 9455:     }
 9456:     my $uhome;
 9457:     if (($uname ne '') && ($udom ne '')) {
 9458:         $uhome = &homeserver($uname,$udom);
 9459:         return $uhome if ($uhome eq 'no_host');
 9460:     } else {
 9461:         $uname = $env{'user.name'};
 9462:         $udom = $env{'user.domain'};
 9463:         $uhome = $env{'user.home'};
 9464:     }
 9465:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
 9466:                 "$udom:$uname:rolesdef_$rolename=".
 9467:                 escape($sysrole.'_'.$domrole.'_'.$courole);
 9468:     return reply($command,$uhome);
 9469:   } else {
 9470:     return 'refused';
 9471:   }
 9472: }
 9473: 
 9474: # ---------------- Make a metadata query against the network of library servers
 9475: 
 9476: sub metadata_query {
 9477:     my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;
 9478:     my %rhash;
 9479:     my %libserv = &all_library();
 9480:     my @server_list = (defined($server_array) ? @$server_array
 9481:                                               : keys(%libserv) );
 9482:     for my $server (@server_list) {
 9483:         my $domains = ''; 
 9484:         if (ref($domains_hash) eq 'HASH') {
 9485:             $domains = $domains_hash->{$server}; 
 9486:         }
 9487: 	unless ($custom or $customshow) {
 9488: 	    my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
 9489: 	    $rhash{$server}=$reply;
 9490: 	}
 9491: 	else {
 9492: 	    my $reply=&reply("querysend:".&escape($query).':'.
 9493: 			     &escape($custom).':'.&escape($customshow).':'.&escape($domains),
 9494: 			     $server);
 9495: 	    $rhash{$server}=$reply;
 9496: 	}
 9497:     }
 9498:     return \%rhash;
 9499: }
 9500: 
 9501: # ----------------------------------------- Send log queries and wait for reply
 9502: 
 9503: sub log_query {
 9504:     my ($uname,$udom,$query,%filters)=@_;
 9505:     my $uhome=&homeserver($uname,$udom);
 9506:     if ($uhome eq 'no_host') { return 'error: no_host'; }
 9507:     my $uhost=&hostname($uhome);
 9508:     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
 9509:     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
 9510:                        $uhome);
 9511:     unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
 9512:     return get_query_reply($queryid);
 9513: }
 9514: 
 9515: # -------------------------- Update MySQL table for portfolio file
 9516: 
 9517: sub update_portfolio_table {
 9518:     my ($uname,$udom,$file_name,$query,$group,$action) = @_;
 9519:     if ($group ne '') {
 9520:         $file_name =~s /^\Q$group\E//;
 9521:     }
 9522:     my $homeserver = &homeserver($uname,$udom);
 9523:     my $queryid=
 9524:         &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
 9525:                ':'.&escape($file_name).':'.$action,$homeserver);
 9526:     my $reply = &get_query_reply($queryid);
 9527:     return $reply;
 9528: }
 9529: 
 9530: # -------------------------- Update MySQL allusers table
 9531: 
 9532: sub update_allusers_table {
 9533:     my ($uname,$udom,$names) = @_;
 9534:     my $homeserver = &homeserver($uname,$udom);
 9535:     my $queryid=
 9536:         &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'.
 9537:                'lastname='.&escape($names->{'lastname'}).'%%'.
 9538:                'firstname='.&escape($names->{'firstname'}).'%%'.
 9539:                'middlename='.&escape($names->{'middlename'}).'%%'.
 9540:                'generation='.&escape($names->{'generation'}).'%%'.
 9541:                'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
 9542:                'id='.&escape($names->{'id'}),$homeserver);
 9543:     return;
 9544: }
 9545: 
 9546: # ------- Request retrieval of institutional classlists for course(s)
 9547: 
 9548: sub fetch_enrollment_query {
 9549:     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
 9550:     my ($homeserver,$sleep,$loopmax);
 9551:     my $maxtries = 1;
 9552:     if ($context eq 'automated') {
 9553:         $homeserver = $perlvar{'lonHostID'};
 9554:         $sleep = 2;
 9555:         $loopmax = 100;
 9556:         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
 9557:     } else {
 9558:         $homeserver = &homeserver($cnum,$dom);
 9559:     }
 9560:     my $host=&hostname($homeserver);
 9561:     my $cmd = '';
 9562:     foreach my $affiliate (keys(%{$affiliatesref})) {
 9563:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
 9564:     }
 9565:     $cmd =~ s/%%$//;
 9566:     $cmd = &escape($cmd);
 9567:     my $query = 'fetchenrollment';
 9568:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver);
 9569:     unless ($queryid=~/^\Q$host\E\_/) { 
 9570:         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
 9571:         return 'error: '.$queryid;
 9572:     }
 9573:     my $reply = &get_query_reply($queryid,$sleep,$loopmax);
 9574:     my $tries = 1;
 9575:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
 9576:         $reply = &get_query_reply($queryid,$sleep,$loopmax);
 9577:         $tries ++;
 9578:     }
 9579:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
 9580:         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
 9581:     } else {
 9582:         my @responses = split(/:/,$reply);
 9583:         if (grep { $_ eq $homeserver } &current_machine_ids()) {
 9584:             foreach my $line (@responses) {
 9585:                 my ($key,$value) = split(/=/,$line,2);
 9586:                 $$replyref{$key} = $value;
 9587:             }
 9588:         } else {
 9589:             my $pathname = LONCAPA::tempdir();
 9590:             foreach my $line (@responses) {
 9591:                 my ($key,$value) = split(/=/,$line);
 9592:                 $$replyref{$key} = $value;
 9593:                 if ($value > 0) {
 9594:                     foreach my $item (@{$$affiliatesref{$key}}) {
 9595:                         my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
 9596:                         my $destname = $pathname.'/'.$filename;
 9597:                         my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
 9598:                         if ($xml_classlist =~ /^error/) {
 9599:                             &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
 9600:                         } else {
 9601:                             if ( open(FILE,">",$destname) ) {
 9602:                                 print FILE &unescape($xml_classlist);
 9603:                                 close(FILE);
 9604:                             } else {
 9605:                                 &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
 9606:                             }
 9607:                         }
 9608:                     }
 9609:                 }
 9610:             }
 9611:         }
 9612:         return 'ok';
 9613:     }
 9614:     return 'error';
 9615: }
 9616: 
 9617: sub get_query_reply {
 9618:     my ($queryid,$sleep,$loopmax) = @_;
 9619:     if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {
 9620:         $sleep = 0.2;
 9621:     }
 9622:     if (($loopmax eq '') || ($loopmax =~ /\D/)) {
 9623:         $loopmax = 100;
 9624:     }
 9625:     my $replyfile=LONCAPA::tempdir().$queryid;
 9626:     my $reply='';
 9627:     for (1..$loopmax) {
 9628: 	sleep($sleep);
 9629:         if (-e $replyfile.'.end') {
 9630: 	    if (open(my $fh,"<",$replyfile)) {
 9631: 		$reply = join('',<$fh>);
 9632: 		close($fh);
 9633: 	   } else { return 'error: reply_file_error'; }
 9634:            return &unescape($reply);
 9635: 	}
 9636:     }
 9637:     return 'timeout:'.$queryid;
 9638: }
 9639: 
 9640: sub courselog_query {
 9641: #
 9642: # possible filters:
 9643: # url: url or symb
 9644: # username
 9645: # domain
 9646: # action: view, submit, grade
 9647: # start: timestamp
 9648: # end: timestamp
 9649: #
 9650:     my (%filters)=@_;
 9651:     unless ($env{'request.course.id'}) { return 'no_course'; }
 9652:     if ($filters{'url'}) {
 9653: 	$filters{'url'}=&symbclean(&declutter($filters{'url'}));
 9654:         $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
 9655:         $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
 9656:     }
 9657:     my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
 9658:     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 9659:     return &log_query($cname,$cdom,'courselog',%filters);
 9660: }
 9661: 
 9662: sub userlog_query {
 9663: #
 9664: # possible filters:
 9665: # action: log check role
 9666: # start: timestamp
 9667: # end: timestamp
 9668: #
 9669:     my ($uname,$udom,%filters)=@_;
 9670:     return &log_query($uname,$udom,'userlog',%filters);
 9671: }
 9672: 
 9673: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 
 9674: 
 9675: sub auto_run {
 9676:     my ($cnum,$cdom) = @_;
 9677:     my $response = 0;
 9678:     my $settings;
 9679:     my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
 9680:     if (ref($domconfig{'autoenroll'}) eq 'HASH') {
 9681:         $settings = $domconfig{'autoenroll'};
 9682:         if ($settings->{'run'} eq '1') {
 9683:             $response = 1;
 9684:         }
 9685:     } else {
 9686:         my $homeserver;
 9687:         if (&is_course($cdom,$cnum)) {
 9688:             $homeserver = &homeserver($cnum,$cdom);
 9689:         } else {
 9690:             $homeserver = &domain($cdom,'primary');
 9691:         }
 9692:         if ($homeserver ne 'no_host') {
 9693:             $response = &reply('autorun:'.$cdom,$homeserver);
 9694:         }
 9695:     }
 9696:     return $response;
 9697: }
 9698: 
 9699: sub auto_get_sections {
 9700:     my ($cnum,$cdom,$inst_coursecode) = @_;
 9701:     my $homeserver;
 9702:     if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { 
 9703:         $homeserver = &homeserver($cnum,$cdom);
 9704:     }
 9705:     if (!defined($homeserver)) { 
 9706:         if ($cdom =~ /^$match_domain$/) {
 9707:             $homeserver = &domain($cdom,'primary');
 9708:         }
 9709:     }
 9710:     my @secs;
 9711:     if (defined($homeserver)) {
 9712:         my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
 9713:         unless ($response eq 'refused') {
 9714:             @secs = split(/:/,$response);
 9715:         }
 9716:     }
 9717:     return @secs;
 9718: }
 9719: 
 9720: sub auto_new_course {
 9721:     my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_;
 9722:     my $homeserver = &homeserver($cnum,$cdom);
 9723:     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver));
 9724:     return $response;
 9725: }
 9726: 
 9727: sub auto_validate_courseID {
 9728:     my ($cnum,$cdom,$inst_course_id) = @_;
 9729:     my $homeserver = &homeserver($cnum,$cdom);
 9730:     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
 9731:     return $response;
 9732: }
 9733: 
 9734: sub auto_validate_instcode {
 9735:     my ($cnum,$cdom,$instcode,$owner) = @_;
 9736:     my ($homeserver,$response);
 9737:     if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
 9738:         $homeserver = &homeserver($cnum,$cdom);
 9739:     }
 9740:     if (!defined($homeserver)) {
 9741:         if ($cdom =~ /^$match_domain$/) {
 9742:             $homeserver = &domain($cdom,'primary');
 9743:         }
 9744:     }
 9745:     $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
 9746:                         &escape($instcode).':'.&escape($owner),$homeserver));
 9747:     my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3);
 9748:     return ($outcome,$description,$defaultcredits);
 9749: }
 9750: 
 9751: sub auto_validate_inst_crosslist {
 9752:     my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
 9753:     my ($homeserver,$response);
 9754:     if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
 9755:         $homeserver = &homeserver($cnum,$cdom);
 9756:     }
 9757:     if (!defined($homeserver)) {
 9758:         if ($cdom =~ /^$match_domain$/) {
 9759:             $homeserver = &domain($cdom,'primary');
 9760:         }
 9761:     }
 9762:     unless (($homeserver eq '') || ($homeserver eq 'no_host')) {
 9763:         $response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
 9764:                          &escape($instcode).':'.&escape($inst_xlist).':'.
 9765:                          &escape($coowner),$homeserver);
 9766:     }
 9767:     return $response;
 9768: }
 9769: 
 9770: sub auto_create_password {
 9771:     my ($cnum,$cdom,$authparam,$udom) = @_;
 9772:     my ($homeserver,$response);
 9773:     my $create_passwd = 0;
 9774:     my $authchk = '';
 9775:     if ($udom =~ /^$match_domain$/) {
 9776:         $homeserver = &domain($udom,'primary');
 9777:     }
 9778:     if ($homeserver eq '') {
 9779:         if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
 9780:             $homeserver = &homeserver($cnum,$cdom);
 9781:         }
 9782:     }
 9783:     if ($homeserver eq '') {
 9784:         $authchk = 'nodomain';
 9785:     } else {
 9786:         $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
 9787:         if ($response eq 'refused') {
 9788:             $authchk = 'refused';
 9789:         } else {
 9790:             ($authparam,$create_passwd,$authchk) = split(/:/,$response);
 9791:         }
 9792:     }
 9793:     return ($authparam,$create_passwd,$authchk);
 9794: }
 9795: 
 9796: sub auto_photo_permission {
 9797:     my ($cnum,$cdom,$students) = @_;
 9798:     my $homeserver = &homeserver($cnum,$cdom);
 9799:     my ($outcome,$perm_reqd,$conditions) = 
 9800: 	split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
 9801:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 9802: 	return (undef,undef);
 9803:     }
 9804:     return ($outcome,$perm_reqd,$conditions);
 9805: }
 9806: 
 9807: sub auto_checkphotos {
 9808:     my ($uname,$udom,$pid) = @_;
 9809:     my $homeserver = &homeserver($uname,$udom);
 9810:     my ($result,$resulttype);
 9811:     my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
 9812: 				   &escape($uname).':'.&escape($pid),
 9813: 				   $homeserver));
 9814:     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 9815: 	return (undef,undef);
 9816:     }
 9817:     if ($outcome) {
 9818:         ($result,$resulttype) = split(/:/,$outcome);
 9819:     } 
 9820:     return ($result,$resulttype);
 9821: }
 9822: 
 9823: sub auto_photochoice {
 9824:     my ($cnum,$cdom) = @_;
 9825:     my $homeserver = &homeserver($cnum,$cdom);
 9826:     my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
 9827: 						       &escape($cdom),
 9828: 						       $homeserver)));
 9829:     if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
 9830: 	return (undef,undef);
 9831:     }
 9832:     return ($update,$comment);
 9833: }
 9834: 
 9835: sub auto_photoupdate {
 9836:     my ($affiliatesref,$dom,$cnum,$photo) = @_;
 9837:     my $homeserver = &homeserver($cnum,$dom);
 9838:     my $host=&hostname($homeserver);
 9839:     my $cmd = '';
 9840:     my $maxtries = 1;
 9841:     foreach my $affiliate (keys(%{$affiliatesref})) {
 9842:         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
 9843:     }
 9844:     $cmd =~ s/%%$//;
 9845:     $cmd = &escape($cmd);
 9846:     my $query = 'institutionalphotos';
 9847:     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
 9848:     unless ($queryid=~/^\Q$host\E\_/) {
 9849:         &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
 9850:         return 'error: '.$queryid;
 9851:     }
 9852:     my $reply = &get_query_reply($queryid);
 9853:     my $tries = 1;
 9854:     while (($reply=~/^timeout/) && ($tries < $maxtries)) {
 9855:         $reply = &get_query_reply($queryid);
 9856:         $tries ++;
 9857:     }
 9858:     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
 9859:         &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
 9860:     } else {
 9861:         my @responses = split(/:/,$reply);
 9862:         my $outcome = shift(@responses); 
 9863:         foreach my $item (@responses) {
 9864:             my ($key,$value) = split(/=/,$item);
 9865:             $$photo{$key} = $value;
 9866:         }
 9867:         return $outcome;
 9868:     }
 9869:     return 'error';
 9870: }
 9871: 
 9872: sub auto_instcode_format {
 9873:     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
 9874: 	$cat_order) = @_;
 9875:     my $courses = '';
 9876:     my @homeservers;
 9877:     if ($caller eq 'global') {
 9878: 	my %servers = &get_servers($codedom,'library');
 9879: 	foreach my $tryserver (keys(%servers)) {
 9880: 	    if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
 9881: 		push(@homeservers,$tryserver);
 9882: 	    }
 9883:         }
 9884:     } elsif ($caller eq 'requests') {
 9885:         if ($codedom =~ /^$match_domain$/) {
 9886:             my $chome = &domain($codedom,'primary');
 9887:             unless ($chome eq 'no_host') {
 9888:                 push(@homeservers,$chome);
 9889:             }
 9890:         }
 9891:     } else {
 9892:         push(@homeservers,&homeserver($caller,$codedom));
 9893:     }
 9894:     foreach my $code (keys(%{$instcodes})) {
 9895:         $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
 9896:     }
 9897:     chop($courses);
 9898:     my $ok_response = 0;
 9899:     my $response;
 9900:     while (@homeservers > 0 && $ok_response == 0) {
 9901:         my $server = shift(@homeservers); 
 9902:         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
 9903:         if ($response !~ /(con_lost|error|no_such_host|refused)/) {
 9904:             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
 9905: 		split(/:/,$response);
 9906:             %{$codes} = (%{$codes},&str2hash($codes_str));
 9907:             push(@{$codetitles},&str2array($codetitles_str));
 9908:             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
 9909:             %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
 9910:             $ok_response = 1;
 9911:         }
 9912:     }
 9913:     if ($ok_response) {
 9914:         return 'ok';
 9915:     } else {
 9916:         return $response;
 9917:     }
 9918: }
 9919: 
 9920: sub auto_instcode_defaults {
 9921:     my ($domain,$returnhash,$code_order) = @_;
 9922:     my @homeservers;
 9923: 
 9924:     my %servers = &get_servers($domain,'library');
 9925:     foreach my $tryserver (keys(%servers)) {
 9926: 	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
 9927: 	    push(@homeservers,$tryserver);
 9928: 	}
 9929:     }
 9930: 
 9931:     my $response;
 9932:     foreach my $server (@homeservers) {
 9933:         $response=&reply('autoinstcodedefaults:'.$domain,$server);
 9934:         next if ($response =~ /(con_lost|error|no_such_host|refused)/);
 9935: 	
 9936: 	foreach my $pair (split(/\&/,$response)) {
 9937: 	    my ($name,$value)=split(/\=/,$pair);
 9938: 	    if ($name eq 'code_order') {
 9939: 		@{$code_order} = split(/\&/,&unescape($value));
 9940: 	    } else {
 9941: 		$returnhash->{&unescape($name)}=&unescape($value);
 9942: 	    }
 9943: 	}
 9944: 	return 'ok';
 9945:     }
 9946: 
 9947:     return $response;
 9948: }
 9949: 
 9950: sub auto_possible_instcodes {
 9951:     my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
 9952:     unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && 
 9953:             (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
 9954:         return;
 9955:     }
 9956:     my (@homeservers,$uhome);
 9957:     if (defined(&domain($domain,'primary'))) {
 9958:         $uhome=&domain($domain,'primary');
 9959:         push(@homeservers,&domain($domain,'primary'));
 9960:     } else {
 9961:         my %servers = &get_servers($domain,'library');
 9962:         foreach my $tryserver (keys(%servers)) {
 9963:             if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
 9964:                 push(@homeservers,$tryserver);
 9965:             }
 9966:         }
 9967:     }
 9968:     my $response;
 9969:     foreach my $server (@homeservers) {
 9970:         $response=&reply('autopossibleinstcodes:'.$domain,$server);
 9971:         next if ($response =~ /(con_lost|error|no_such_host|refused)/);
 9972:         my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = 
 9973:             split(':',$response);
 9974:         @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
 9975:         @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
 9976:         foreach my $item (split('&',$cat_title)) {   
 9977:             my ($name,$value)=split('=',$item);
 9978:             $cat_titles->{&unescape($name)}=&thaw_unescape($value);
 9979:         }
 9980:         foreach my $item (split('&',$cat_order)) {
 9981:             my ($name,$value)=split('=',$item);
 9982:             $cat_orders->{&unescape($name)}=&thaw_unescape($value);
 9983:         }
 9984:         return 'ok';
 9985:     }
 9986:     return $response;
 9987: }
 9988: 
 9989: sub auto_courserequest_checks {
 9990:     my ($dom) = @_;
 9991:     my ($homeserver,%validations);
 9992:     if ($dom =~ /^$match_domain$/) {
 9993:         $homeserver = &domain($dom,'primary');
 9994:     }
 9995:     unless ($homeserver eq 'no_host') {
 9996:         my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
 9997:         unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
 9998:             my @items = split(/&/,$response);
 9999:             foreach my $item (@items) {
10000:                 my ($key,$value) = split('=',$item);
10001:                 $validations{&unescape($key)} = &thaw_unescape($value);
10002:             }
10003:         }
10004:     }
10005:     return %validations; 
10006: }
10007: 
10008: sub auto_courserequest_validation {
10009:     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_;
10010:     my ($homeserver,$response);
10011:     if ($dom =~ /^$match_domain$/) {
10012:         $homeserver = &domain($dom,'primary');
10013:     }
10014:     unless ($homeserver eq 'no_host') {
10015:         my $customdata;
10016:         if (ref($custominfo) eq 'HASH') {
10017:             $customdata = &freeze_escape($custominfo);
10018:         }
10019:         $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
10020:                                     ':'.&escape($crstype).':'.&escape($inststatuslist).
10021:                                     ':'.&escape($instcode).':'.&escape($instseclist).':'.
10022:                                     $customdata,$homeserver));
10023:     }
10024:     return $response;
10025: }
10026: 
10027: sub auto_validate_class_sec {
10028:     my ($cdom,$cnum,$owners,$inst_class) = @_;
10029:     my $homeserver = &homeserver($cnum,$cdom);
10030:     my $ownerlist;
10031:     if (ref($owners) eq 'ARRAY') {
10032:         $ownerlist = join(',',@{$owners});
10033:     } else {
10034:         $ownerlist = $owners;
10035:     }
10036:     my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
10037:                         &escape($ownerlist).':'.$cdom,$homeserver);
10038:     return $response;
10039: }
10040: 
10041: sub auto_instsec_reformat {
10042:     my ($cdom,$action,$instsecref) = @_;
10043:     return unless(($action eq 'clutter') || ($action eq 'declutter'));
10044:     my @homeservers;
10045:     if (defined(&domain($cdom,'primary'))) {
10046:         push(@homeservers,&domain($cdom,'primary'));
10047:     } else {
10048:         my %servers = &get_servers($cdom,'library');
10049:         foreach my $tryserver (keys(%servers)) {
10050:             if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
10051:                 push(@homeservers,$tryserver);
10052:             }
10053:         }
10054:     }
10055:     my $response;
10056:     my %reformatted = %{$instsecref};
10057:     foreach my $server (@homeservers) {
10058:         if (ref($instsecref) eq 'HASH') {
10059:             my $info = &freeze_escape($instsecref);
10060:             my $response=&reply('autoinstsecreformat:'.$cdom.':'.
10061:                                 $action.':'.$info,$server);
10062:             next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);
10063:             my @items = split(/&/,$response);
10064:             foreach my $item (@items) {
10065:                 my ($key,$value) = split(/=/,$item);
10066:                 $reformatted{&unescape($key)} = &thaw_unescape($value);
10067:             }
10068:         }
10069:     }
10070:     return %reformatted;
10071: }
10072: 
10073: sub auto_validate_instclasses {
10074:     my ($cdom,$cnum,$owners,$classesref) = @_;
10075:     my ($homeserver,%validations);
10076:     $homeserver = &homeserver($cnum,$cdom);
10077:     unless ($homeserver eq 'no_host') {
10078:         my $ownerlist;
10079:         if (ref($owners) eq 'ARRAY') {
10080:             $ownerlist = join(',',@{$owners});
10081:         } else {
10082:             $ownerlist = $owners;
10083:         }
10084:         if (ref($classesref) eq 'HASH') {
10085:             my $classes = &freeze_escape($classesref);
10086:             my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist).
10087:                                 ':'.$cdom.':'.$classes,$homeserver);
10088:             unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
10089:                 my @items = split(/&/,$response);
10090:                 foreach my $item (@items) {
10091:                     my ($key,$value) = split('=',$item);
10092:                     $validations{&unescape($key)} = &thaw_unescape($value);
10093:                 }
10094:             }
10095:         }
10096:     }
10097:     return %validations;
10098: }
10099: 
10100: sub auto_crsreq_update {
10101:     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
10102:         $code,$accessstart,$accessend,$inbound) = @_;
10103:     my ($homeserver,%crsreqresponse);
10104:     if ($cdom =~ /^$match_domain$/) {
10105:         $homeserver = &domain($cdom,'primary');
10106:     }
10107:     unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
10108:         my $info;
10109:         if (ref($inbound) eq 'HASH') {
10110:             $info = &freeze_escape($inbound);
10111:         }
10112:         my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
10113:                             ':'.&escape($action).':'.&escape($ownername).':'.
10114:                             &escape($ownerdomain).':'.&escape($fullname).':'.
10115:                             &escape($title).':'.&escape($code).':'.
10116:                             &escape($accessstart).':'.&escape($accessend).':'.$info,
10117:                             $homeserver);
10118:         unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
10119:             my @items = split(/&/,$response);
10120:             foreach my $item (@items) {
10121:                 my ($key,$value) = split('=',$item);
10122:                 $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
10123:             }
10124:         }
10125:     }
10126:     return \%crsreqresponse;
10127: }
10128: 
10129: sub auto_export_grades {
10130:     my ($cdom,$cnum,$inforef,$gradesref) = @_;
10131:     my ($homeserver,%exportresponse);
10132:     if ($cdom =~ /^$match_domain$/) {
10133:         $homeserver = &domain($cdom,'primary');
10134:     }
10135:     unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
10136:         my $info;
10137:         if (ref($inforef) eq 'HASH') {
10138:             $info = &freeze_escape($inforef);
10139:         }
10140:         if (ref($gradesref) eq 'HASH') {
10141:             my $grades = &freeze_escape($gradesref);
10142:             my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
10143:                                 $info.':'.$grades,$homeserver);
10144:             unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
10145:                 my @items = split(/&/,$response);
10146:                 foreach my $item (@items) {
10147:                     my ($key,$value) = split('=',$item);
10148:                     $exportresponse{&unescape($key)} = &thaw_unescape($value);
10149:                 }
10150:             }
10151:         }
10152:     }
10153:     return \%exportresponse;
10154: }
10155: 
10156: sub check_instcode_cloning {
10157:     my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
10158:     unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
10159:         return;
10160:     }
10161:     my $canclone;
10162:     if (@{$code_order} > 0) {
10163:         my $instcoderegexp ='^';
10164:         my @clonecodes = split(/\&/,$cloner);
10165:         foreach my $item (@{$code_order}) {
10166:             if (grep(/^\Q$item\E=/,@clonecodes)) {
10167:                 foreach my $pair (@clonecodes) {
10168:                     my ($key,$val) = split(/\=/,$pair,2);
10169:                     $val = &unescape($val);
10170:                     if ($key eq $item) {
10171:                         $instcoderegexp .= '('.$val.')';
10172:                         last;
10173:                     }
10174:                 }
10175:             } else {
10176:                 $instcoderegexp .= $codedefaults->{$item};
10177:             }
10178:         }
10179:         $instcoderegexp .= '$';
10180:         my (@from,@to);
10181:         eval {
10182:                (@from) = ($clonefromcode =~ /$instcoderegexp/);
10183:                (@to) = ($clonetocode =~ /$instcoderegexp/);
10184:         };
10185:         if ((@from > 0) && (@to > 0)) {
10186:             my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
10187:             if (!@diffs) {
10188:                 $canclone = 1;
10189:             }
10190:         }
10191:     }
10192:     return $canclone;
10193: }
10194: 
10195: sub default_instcode_cloning {
10196:     my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_;
10197:     my (%codedefaults,@code_order,$canclone);
10198:     if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) {
10199:         %codedefaults = %{$codedefaultsref};
10200:         @code_order = @{$codeorderref};
10201:     } elsif ($clonedom) {
10202:         &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order);
10203:     }
10204:     if (($domdefclone) && (@code_order)) {
10205:         my @clonecodes = split(/\+/,$domdefclone);
10206:         my $instcoderegexp ='^';
10207:         foreach my $item (@code_order) {
10208:             if (grep(/^\Q$item\E$/,@clonecodes)) {
10209:                 $instcoderegexp .= '('.$codedefaults{$item}.')';
10210:             } else {
10211:                 $instcoderegexp .= $codedefaults{$item};
10212:             }
10213:         }
10214:         $instcoderegexp .= '$';
10215:         my (@from,@to);
10216:         eval {
10217:             (@from) = ($clonefromcode =~ /$instcoderegexp/);
10218:             (@to) = ($clonetocode =~ /$instcoderegexp/);
10219:         };
10220:         if ((@from > 0) && (@to > 0)) {
10221:             my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
10222:             if (!@diffs) {
10223:                 $canclone = 1;
10224:             }
10225:         }
10226:     }
10227:     return $canclone;
10228: }
10229: 
10230: # ------------------------------------------------------- Course Group routines
10231: 
10232: sub get_coursegroups {
10233:     my ($cdom,$cnum,$group,$namespace) = @_;
10234:     return(&dump($namespace,$cdom,$cnum,$group));
10235: }
10236: 
10237: sub modify_coursegroup {
10238:     my ($cdom,$cnum,$groupsettings) = @_;
10239:     return(&put('coursegroups',$groupsettings,$cdom,$cnum));
10240: }
10241: 
10242: sub toggle_coursegroup_status {
10243:     my ($cdom,$cnum,$group,$action) = @_;
10244:     my ($from_namespace,$to_namespace);
10245:     if ($action eq 'delete') {
10246:         $from_namespace = 'coursegroups';
10247:         $to_namespace = 'deleted_groups';
10248:     } else {
10249:         $from_namespace = 'deleted_groups';
10250:         $to_namespace = 'coursegroups';
10251:     }
10252:     my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
10253:     if (my $tmp = &error(%curr_group)) {
10254:         &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
10255:         return ('read error',$tmp);
10256:     } else {
10257:         my %savedsettings = %curr_group; 
10258:         my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
10259:         my $deloutcome;
10260:         if ($result eq 'ok') {
10261:             $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
10262:         } else {
10263:             return ('write error',$result);
10264:         }
10265:         if ($deloutcome eq 'ok') {
10266:             return 'ok';
10267:         } else {
10268:             return ('delete error',$deloutcome);
10269:         }
10270:     }
10271: }
10272: 
10273: sub modify_group_roles {
10274:     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
10275:     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
10276:     my $role = 'gr/'.&escape($userprivs);
10277:     my ($uname,$udom) = split(/:/,$user);
10278:     my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
10279:     if ($result eq 'ok') {
10280:         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
10281:     }
10282:     return $result;
10283: }
10284: 
10285: sub modify_coursegroup_membership {
10286:     my ($cdom,$cnum,$membership) = @_;
10287:     my $result = &put('groupmembership',$membership,$cdom,$cnum);
10288:     return $result;
10289: }
10290: 
10291: sub get_active_groups {
10292:     my ($udom,$uname,$cdom,$cnum) = @_;
10293:     my $now = time;
10294:     my %groups = ();
10295:     foreach my $key (keys(%env)) {
10296:         if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
10297:             my ($start,$end) = split(/\./,$env{$key});
10298:             if (($end!=0) && ($end<$now)) { next; }
10299:             if (($start!=0) && ($start>$now)) { next; }
10300:             if ($1 eq $cdom && $2 eq $cnum) {
10301:                 $groups{$3} = $env{$key} ;
10302:             }
10303:         }
10304:     }
10305:     return %groups;
10306: }
10307: 
10308: sub get_group_membership {
10309:     my ($cdom,$cnum,$group) = @_;
10310:     return(&dump('groupmembership',$cdom,$cnum,$group));
10311: }
10312: 
10313: sub get_users_groups {
10314:     my ($udom,$uname,$courseid) = @_;
10315:     my @usersgroups;
10316:     my $cachetime=1800;
10317: 
10318:     my $hashid="$udom:$uname:$courseid";
10319:     my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
10320:     if (defined($cached)) {
10321:         @usersgroups = split(/:/,$grouplist);
10322:     } else {  
10323:         $grouplist = '';
10324:         my $courseurl = &courseid_to_courseurl($courseid);
10325:         my %roleshash = &dump('roles',$udom,$uname,$courseurl);
10326:         my $access_end = $env{'course.'.$courseid.
10327:                               '.default_enrollment_end_date'};
10328:         my $now = time;
10329:         foreach my $key (keys(%roleshash)) {
10330:             if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
10331:                 my $group = $1;
10332:                 if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
10333:                     my $start = $2;
10334:                     my $end = $1;
10335:                     if ($start == -1) { next; } # deleted from group
10336:                     if (($start!=0) && ($start>$now)) { next; }
10337:                     if (($end!=0) && ($end<$now)) {
10338:                         if ($access_end && $access_end < $now) {
10339:                             if ($access_end - $end < 86400) {
10340:                                 push(@usersgroups,$group);
10341:                             }
10342:                         }
10343:                         next;
10344:                     }
10345:                     push(@usersgroups,$group);
10346:                 }
10347:             }
10348:         }
10349:         @usersgroups = &sort_course_groups($courseid,@usersgroups);
10350:         $grouplist = join(':',@usersgroups);
10351:         &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
10352:     }
10353:     return @usersgroups;
10354: }
10355: 
10356: sub devalidate_getgroups_cache {
10357:     my ($udom,$uname,$cdom,$cnum)=@_;
10358:     my $courseid = $cdom.'_'.$cnum;
10359: 
10360:     my $hashid="$udom:$uname:$courseid";
10361:     &devalidate_cache_new('getgroups',$hashid);
10362: }
10363: 
10364: # ------------------------------------------------------------------ Plain Text
10365: 
10366: sub plaintext {
10367:     my ($short,$type,$cid,$forcedefault) = @_;
10368:     if ($short =~ m{^cr/}) {
10369: 	return (split('/',$short))[-1];
10370:     }
10371:     if (!defined($cid)) {
10372:         $cid = $env{'request.course.id'};
10373:     }
10374:     my %rolenames = (
10375:                       Course    => 'std',
10376:                       Community => 'alt1',
10377:                       Placement => 'std',
10378:                     );
10379:     if ($cid ne '') {
10380:         if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
10381:             unless ($forcedefault) {
10382:                 my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; 
10383:                 &Apache::lonlocal::mt_escape(\$roletext);
10384:                 return &Apache::lonlocal::mt($roletext);
10385:             }
10386:         }
10387:     }
10388:     if ((defined($type)) && (defined($rolenames{$type})) &&
10389:         (defined($rolenames{$type})) && 
10390:         (defined($prp{$short}{$rolenames{$type}}))) {
10391:         return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
10392:     } elsif ($cid ne '') {
10393:         my $crstype = $env{'course.'.$cid.'.type'};
10394:         if (($crstype ne '') && (defined($rolenames{$crstype})) &&
10395:             (defined($prp{$short}{$rolenames{$crstype}}))) {
10396:             return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}});
10397:         }
10398:     }
10399:     return &Apache::lonlocal::mt($prp{$short}{'std'});
10400: }
10401: 
10402: # ----------------------------------------------------------------- Assign Role
10403: 
10404: sub assignrole {
10405:     my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
10406:         $context)=@_;
10407:     my $mrole;
10408:     if ($role =~ /^cr\//) {
10409:         my $cwosec=$url;
10410:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
10411:         if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
10412:            my $refused = 1;
10413:            if ($context eq 'requestcourses') {
10414:                if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
10415:                    if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
10416:                        if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
10417:                            my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
10418:                            my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
10419:                            if ($crsenv{'internal.courseowner'} eq
10420:                                $env{'user.name'}.':'.$env{'user.domain'}) {
10421:                                $refused = '';
10422:                            }
10423:                        }
10424:                    }
10425:                }
10426:            }
10427:            if ($refused) {
10428:                &logthis('Refused custom assignrole: '.
10429:                         $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
10430:                         ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
10431:                return 'refused';
10432:            }
10433:         }
10434:         $mrole='cr';
10435:     } elsif ($role =~ /^gr\//) {
10436:         my $cwogrp=$url;
10437:         $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
10438:         unless (&allowed('mdg',$cwogrp)) {
10439:             &logthis('Refused group assignrole: '.
10440:               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
10441:                     $env{'user.name'}.' at '.$env{'user.domain'});
10442:             return 'refused';
10443:         }
10444:         $mrole='gr';
10445:     } else {
10446:         my $cwosec=$url;
10447:         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
10448:         if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
10449:             my $refused;
10450:             if (($env{'request.course.sec'}  ne '') && ($role eq 'st')) {
10451:                 if (!(&allowed('c'.$role,$url))) {
10452:                     $refused = 1;
10453:                 }
10454:             } else {
10455:                 $refused = 1;
10456:             }
10457:             if ($refused) {
10458:                 my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
10459:                 if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
10460:                     my %crsenv;
10461:                     if ($role eq 'cc' || $role eq 'co') {
10462:                         %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
10463:                         if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {
10464:                             if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {
10465:                                 if ($crsenv{'internal.courseowner'} eq 
10466:                                     $env{'user.name'}.':'.$env{'user.domain'}) {
10467:                                     $refused = '';
10468:                                 }
10469:                             }
10470:                         } elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { 
10471:                             if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) {
10472:                                 if ($crsenv{'internal.courseowner'} eq 
10473:                                     $env{'user.name'}.':'.$env{'user.domain'}) {
10474:                                     $refused = '';
10475:                                 }
10476:                             }
10477:                         }
10478:                     }
10479:                 } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
10480:                     if ($role eq 'st') {
10481:                         $refused = '';
10482:                     } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
10483:                         $refused = '';
10484:                     }
10485:                 } elsif ($context eq 'requestcourses') {
10486:                     my @possroles = ('st','ta','ep','in','cc','co');
10487:                     if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
10488:                         my $wrongcc;
10489:                         if ($cnum =~ /^$match_community$/) {
10490:                             $wrongcc = 1 if ($role eq 'cc');
10491:                         } else {
10492:                             $wrongcc = 1 if ($role eq 'co');
10493:                         }
10494:                         unless ($wrongcc) {
10495:                             my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
10496:                             if ($crsenv{'internal.courseowner'} eq 
10497:                                  $env{'user.name'}.':'.$env{'user.domain'}) {
10498:                                 $refused = '';
10499:                             }
10500:                         }
10501:                     }
10502:                 } elsif ($context eq 'requestauthor') {
10503:                     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 
10504:                         ($url eq '/'.$udom.'/') && ($role eq 'au')) {
10505:                         if ($env{'environment.requestauthor'} eq 'automatic') {
10506:                             $refused = '';
10507:                         } else {
10508:                             my %domdefaults = &get_domain_defaults($udom);
10509:                             if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
10510:                                 my $checkbystatus;
10511:                                 if ($env{'user.adv'}) { 
10512:                                     my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
10513:                                     if ($disposition eq 'automatic') {
10514:                                         $refused = '';
10515:                                     } elsif ($disposition eq '') {
10516:                                         $checkbystatus = 1;
10517:                                     } 
10518:                                 } else {
10519:                                     $checkbystatus = 1;
10520:                                 }
10521:                                 if ($checkbystatus) {
10522:                                     if ($env{'environment.inststatus'}) {
10523:                                         my @inststatuses = split(/,/,$env{'environment.inststatus'});
10524:                                         foreach my $type (@inststatuses) {
10525:                                             if (($type ne '') &&
10526:                                                 ($domdefaults{'requestauthor'}{$type} eq 'automatic')) {
10527:                                                 $refused = '';
10528:                                             }
10529:                                         }
10530:                                     } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') {
10531:                                         $refused = '';
10532:                                     }
10533:                                 }
10534:                             }
10535:                         }
10536:                     }
10537:                 }
10538:                 if ($refused) {
10539:                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
10540:                              ' '.$role.' '.$end.' '.$start.' by '.
10541: 	  	             $env{'user.name'}.' at '.$env{'user.domain'});
10542:                     return 'refused';
10543:                 }
10544:             }
10545:         } elsif ($role eq 'au') {
10546:             if ($url ne '/'.$udom.'/') {
10547:                 &logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}.
10548:                          ' to assign author role for '.$uname.':'.$udom.
10549:                          ' in domain: '.$url.' refused (wrong domain).');
10550:                 return 'refused';
10551:             }
10552:         }
10553:         $mrole=$role;
10554:     }
10555:     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
10556:                 "$udom:$uname:$url".'_'."$mrole=$role";
10557:     if ($end) { $command.='_'.$end; }
10558:     if ($start) {
10559: 	if ($end) { 
10560:            $command.='_'.$start; 
10561:         } else {
10562:            $command.='_0_'.$start;
10563:         }
10564:     }
10565:     my $origstart = $start;
10566:     my $origend = $end;
10567:     my $delflag;
10568: # actually delete
10569:     if ($deleteflag) {
10570: 	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
10571: # modify command to delete the role
10572:            $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:".
10573:                 "$udom:$uname:$url".'_'."$mrole";
10574: 	   &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
10575: # set start and finish to negative values for userrolelog
10576:            $start=-1;
10577:            $end=-1;
10578:            $delflag = 1;
10579:         }
10580:     }
10581: # send command
10582:     my $answer=&reply($command,&homeserver($uname,$udom));
10583: # log new user role if status is ok
10584:     if ($answer eq 'ok') {
10585: 	&userrolelog($role,$uname,$udom,$url,$start,$end);
10586:         if (($role eq 'cc') || ($role eq 'in') ||
10587:             ($role eq 'ep') || ($role eq 'ad') ||
10588:             ($role eq 'ta') || ($role eq 'st') ||
10589:             ($role=~/^cr/) || ($role eq 'gr') ||
10590:             ($role eq 'co')) {
10591: # for course roles, perform group memberships changes triggered by role change.
10592:             unless ($role =~ /^gr/) {
10593:                 &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
10594:                                                  $origstart,$selfenroll,$context);
10595:             }
10596:             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
10597:                            $selfenroll,$context);
10598:         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
10599:                  ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') ||
10600:                  ($role eq 'da')) {
10601:             &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
10602:                            $context);
10603:         } elsif (($role eq 'ca') || ($role eq 'aa')) {
10604:             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
10605:                              $context); 
10606:         }
10607:         if ($role eq 'cc') {
10608:             &autoupdate_coowners($url,$end,$start,$uname,$udom);
10609:         }
10610:     }
10611:     return $answer;
10612: }
10613: 
10614: sub autoupdate_coowners {
10615:     my ($url,$end,$start,$uname,$udom) = @_;
10616:     my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)});
10617:     if (($cdom ne '') && ($cnum ne '')) {
10618:         my $now = time;
10619:         my %domdesign = &Apache::loncommon::get_domainconf($cdom);
10620:         if ($domdesign{$cdom.'.autoassign.co-owners'}) {
10621:             my %coursehash = &coursedescription($cdom.'_'.$cnum);
10622:             my $instcode = $coursehash{'internal.coursecode'};
10623:             my $xlists = $coursehash{'internal.crosslistings'};
10624:             if ($instcode ne '') {
10625:                 if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
10626:                     unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
10627:                         my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
10628:                         my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
10629:                         unless ($result eq 'valid') {
10630:                             if ($xlists ne '') {
10631:                                 foreach my $xlist (split(',',$xlists)) {
10632:                                     my ($inst_crosslist,$lcsec) = split(':',$xlist);
10633:                                     $result =
10634:                                         &auto_validate_inst_crosslist($cnum,$cdom,$instcode,
10635:                                                                       $inst_crosslist,$uname.':'.$udom);
10636:                                     last if ($result eq 'valid');
10637:                                 }
10638:                             }
10639:                         }
10640:                         if ($result eq 'valid') {
10641:                             if ($coursehash{'internal.co-owners'}) {
10642:                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
10643:                                     push(@newcoowners,$coowner);
10644:                                 }
10645:                                 unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) {
10646:                                     push(@newcoowners,$uname.':'.$udom);
10647:                                 }
10648:                                 @newcoowners = sort(@newcoowners);
10649:                             } else {
10650:                                 push(@newcoowners,$uname.':'.$udom);
10651:                             }
10652:                         } elsif ($coursehash{'internal.co-owners'}) {
10653:                             foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
10654:                                 unless ($coowner eq $uname.':'.$udom) {
10655:                                     push(@newcoowners,$coowner);
10656:                                 }
10657:                             }
10658:                             unless (@newcoowners > 0) {
10659:                                 $delcoowners = 1;
10660:                                 $coowners = '';
10661:                             }
10662:                         }
10663:                         if (@newcoowners || $delcoowners) {
10664:                             &store_coowners($cdom,$cnum,$coursehash{'home'},
10665:                                             $delcoowners,@newcoowners);
10666:                         }
10667:                     }
10668:                 }
10669:             }
10670:         }
10671:     }
10672: }
10673: 
10674: sub store_coowners {
10675:     my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_;
10676:     my $cid = $cdom.'_'.$cnum;
10677:     my ($coowners,$delresult,$putresult);
10678:     if (@newcoowners) {
10679:         $coowners = join(',',@newcoowners);
10680:         my %coownershash = (
10681:                             'internal.co-owners' => $coowners,
10682:                            );
10683:         $putresult = &put('environment',\%coownershash,$cdom,$cnum);
10684:         if ($putresult eq 'ok') {
10685:             if ($env{'course.'.$cid.'.num'} eq $cnum) {
10686:                 &appenv({'course.'.$cid.'.internal.co-owners' => $coowners});
10687:             }
10688:         }
10689:     }
10690:     if ($delcoowners) {
10691:         $delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum);
10692:         if ($delresult eq 'ok') {
10693:             if ($env{'course.'.$cid.'.internal.co-owners'}) {
10694:                 &Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners');
10695:             }
10696:         }
10697:     }
10698:     if (($putresult eq 'ok') || ($delresult eq 'ok')) {
10699:         my %crsinfo =
10700:             &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
10701:         if (ref($crsinfo{$cid}) eq 'HASH') {
10702:             $crsinfo{$cid}{'co-owners'} = \@newcoowners;
10703:             my $cidput = &courseidput($cdom,\%crsinfo,$chome,'notime');
10704:         }
10705:     }
10706: }
10707: 
10708: # -------------------------------------------------- Modify user authentication
10709: # Overrides without validation
10710: 
10711: sub modifyuserauth {
10712:     my ($udom,$uname,$umode,$upass)=@_;
10713:     my $uhome=&homeserver($uname,$udom);
10714:     my $allowed;
10715:     if (&allowed('mau',$udom)) {
10716:         $allowed = 1;
10717:     } elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) &&
10718:              ($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) &&
10719:              (!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) {
10720:         my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
10721:         my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
10722:         if (($cdom ne '') && ($cnum ne '')) {
10723:             my $is_owner = &is_course_owner($cdom,$cnum);
10724:             if ($is_owner) {
10725:                 $allowed = 1;
10726:             }
10727:         }
10728:     }
10729:     unless ($allowed) { return 'refused'; }
10730:     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
10731:              $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
10732:              ' in domain '.$env{'request.role.domain'});  
10733:     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
10734: 		     &escape($upass),$uhome);
10735:     my $ip = &get_requestor_ip();
10736:     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
10737:         'Authentication changed for '.$udom.', '.$uname.', '.$umode.
10738:          '(Remote '.$ip.'): '.$reply);
10739:     &log($udom,,$uname,$uhome,
10740:         'Authentication changed by '.$env{'user.domain'}.', '.
10741:                                      $env{'user.name'}.', '.$umode.
10742:          '(Remote '.$ip.'): '.$reply);
10743:     unless ($reply eq 'ok') {
10744:         &logthis('Authentication mode error: '.$reply);
10745: 	return 'error: '.$reply;
10746:     }   
10747:     return 'ok';
10748: }
10749: 
10750: # --------------------------------------------------------------- Modify a user
10751: 
10752: sub modifyuser {
10753:     my ($udom,    $uname, $uid,
10754:         $umode,   $upass, $first,
10755:         $middle,  $last,  $gene,
10756:         $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;
10757:     $udom= &LONCAPA::clean_domain($udom);
10758:     $uname=&LONCAPA::clean_username($uname);
10759:     my $showcandelete = 'none';
10760:     if (ref($candelete) eq 'ARRAY') {
10761:         if (@{$candelete} > 0) {
10762:             $showcandelete = join(', ',@{$candelete});
10763:         }
10764:     }
10765:     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
10766:              $umode.', '.$first.', '.$middle.', '.
10767: 	     $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
10768:              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
10769:                                      ' desiredhome not specified'). 
10770:              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
10771:              ' in domain '.$env{'request.role.domain'});
10772:     my $uhome=&homeserver($uname,$udom,'true');
10773:     my $newuser;
10774:     if ($uhome eq 'no_host') {
10775:         $newuser = 1;
10776:         unless (($umode && ($upass ne '')) || ($umode eq 'localauth') ||
10777:                 ($umode eq 'lti')) {
10778:             return 'error: more information needed to create new user';
10779:         }
10780:     }
10781: # ----------------------------------------------------------------- Create User
10782:     if (($uhome eq 'no_host') && 
10783: 	(($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) {
10784:         my $unhome='';
10785:         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
10786:             $unhome = $desiredhome;
10787: 	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
10788: 	    $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
10789:         } else { # load balancing routine for determining $unhome
10790:             my $loadm=10000000;
10791: 	    my %servers = &get_servers($udom,'library');
10792: 	    foreach my $tryserver (keys(%servers)) {
10793: 		my $answer=reply('load',$tryserver);
10794: 		if (($answer=~/\d+/) && ($answer<$loadm)) {
10795: 		    $loadm=$answer;
10796: 		    $unhome=$tryserver;
10797: 		}
10798: 	    }
10799:         }
10800:         if (($unhome eq '') || ($unhome eq 'no_host')) {
10801: 	    return 'error: unable to find a home server for '.$uname.
10802:                    ' in domain '.$udom;
10803:         }
10804:         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
10805:                          &escape($upass),$unhome);
10806: 	unless ($reply eq 'ok') {
10807:             return 'error: '.$reply;
10808:         }   
10809:         $uhome=&homeserver($uname,$udom,'true');
10810:         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
10811: 	    return 'error: unable verify users home machine.';
10812:         }
10813:     }   # End of creation of new user
10814: # ---------------------------------------------------------------------- Add ID
10815:     if ($uid) {
10816:        $uid=~tr/A-Z/a-z/;
10817:        my %uidhash=&idrget($udom,$uname);
10818:        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
10819:          && (!$forceid)) {
10820: 	  unless ($uid eq $uidhash{$uname}) {
10821: 	      return 'error: user id "'.$uid.'" does not match '.
10822:                   'current user id "'.$uidhash{$uname}.'".';
10823:           }
10824:        } else {
10825: 	  &idput($udom,{$uname => $uid},$uhome,'ids');
10826:        }
10827:     }
10828: # -------------------------------------------------------------- Add names, etc
10829:     my @tmp=&get('environment',
10830: 		   ['firstname','middlename','lastname','generation','id',
10831:                     'permanentemail','inststatus'],
10832: 		   $udom,$uname);
10833:     my (%names,%oldnames);
10834:     if ($tmp[0] =~ m/^error:.*/) { 
10835:         %names=(); 
10836:     } else {
10837:         %names = @tmp;
10838:         %oldnames = %names;
10839:     }
10840: #
10841: # If name, email and/or uid are blank (e.g., because an uploaded file
10842: # of users did not contain them), do not overwrite existing values
10843: # unless field is in $candelete array ref.  
10844: #
10845: 
10846:     my @fields = ('firstname','middlename','lastname','generation',
10847:                   'permanentemail','id');
10848:     my %newvalues;
10849:     if (ref($candelete) eq 'ARRAY') {
10850:         foreach my $field (@fields) {
10851:             if (grep(/^\Q$field\E$/,@{$candelete})) {
10852:                 if ($field eq 'firstname') {
10853:                     $names{$field} = $first;
10854:                 } elsif ($field eq 'middlename') {
10855:                     $names{$field} = $middle;
10856:                 } elsif ($field eq 'lastname') {
10857:                     $names{$field} = $last;
10858:                 } elsif ($field eq 'generation') { 
10859:                     $names{$field} = $gene;
10860:                 } elsif ($field eq 'permanentemail') {
10861:                     $names{$field} = $email;
10862:                 } elsif ($field eq 'id') {
10863:                     $names{$field}  = $uid;
10864:                 }
10865:             }
10866:         }
10867:     }
10868:     if ($first)  { $names{'firstname'}  = $first; }
10869:     if (defined($middle)) { $names{'middlename'} = $middle; }
10870:     if ($last)   { $names{'lastname'}   = $last; }
10871:     if (defined($gene))   { $names{'generation'} = $gene; }
10872:     if ($email) {
10873:        $email=~s/[^\w\@\.\-\,]//gs;
10874:        if ($email=~/\@/) { $names{'permanentemail'} = $email; }
10875:     }
10876:     if ($uid) { $names{'id'}  = $uid; }
10877:     if (defined($inststatus)) {
10878:         $names{'inststatus'} = '';
10879:         my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
10880:         if (ref($usertypes) eq 'HASH') {
10881:             my @okstatuses; 
10882:             foreach my $item (split(/:/,$inststatus)) {
10883:                 if (defined($usertypes->{$item})) {
10884:                     push(@okstatuses,$item);  
10885:                 }
10886:             }
10887:             if (@okstatuses) {
10888:                 $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
10889:             }
10890:         }
10891:     }
10892:     my $logmsg = $udom.', '.$uname.', '.$uid.', '.
10893:                  $umode.', '.$first.', '.$middle.', '.
10894:                  $last.', '.$gene.', '.$email.', '.$inststatus;
10895:     if ($env{'user.name'} ne '' && $env{'user.domain'}) {
10896:         $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
10897:     } else {
10898:         $logmsg .= ' during self creation';
10899:     }
10900:     my $changed;
10901:     if ($newuser) {
10902:         $changed = 1;
10903:     } else {
10904:         foreach my $field (@fields) {
10905:             if ($names{$field} ne $oldnames{$field}) {
10906:                 $changed = 1;
10907:                 last;
10908:             }
10909:         }
10910:     }
10911:     unless ($changed) {
10912:         $logmsg = 'No changes in user information needed for: '.$logmsg;
10913:         &logthis($logmsg);
10914:         return 'ok';
10915:     }
10916:     my $reply = &put('environment', \%names, $udom,$uname);
10917:     if ($reply ne 'ok') { 
10918:         return 'error: '.$reply;
10919:     }
10920:     if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
10921:         &devalidate_cache_new('emailscache',$uname.':'.$udom);
10922:     }
10923:     my $sqlresult = &update_allusers_table($uname,$udom,\%names);
10924:     &devalidate_cache_new('namescache',$uname.':'.$udom);
10925:     $logmsg = 'Success modifying user '.$logmsg;
10926:     &logthis($logmsg);
10927:     return 'ok';
10928: }
10929: 
10930: # -------------------------------------------------------------- Modify student
10931: 
10932: sub modifystudent {
10933:     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
10934:         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
10935:         $selfenroll,$context,$inststatus,$credits,$instsec)=@_;
10936:     if (!$cid) {
10937: 	unless ($cid=$env{'request.course.id'}) {
10938: 	    return 'not_in_class';
10939: 	}
10940:     }
10941: # --------------------------------------------------------------- Make the user
10942:     my $reply=&modifyuser
10943: 	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
10944:          $desiredhome,$email,$inststatus);
10945:     unless ($reply eq 'ok') { return $reply; }
10946:     # This will cause &modify_student_enrollment to get the uid from the
10947:     # student's environment
10948:     $uid = undef if (!$forceid);
10949:     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
10950:                                         $gene,$usec,$end,$start,$type,$locktype,
10951:                                         $cid,$selfenroll,$context,$credits,$instsec);
10952:     return $reply;
10953: }
10954: 
10955: sub modify_student_enrollment {
10956:     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
10957:         $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
10958:     my ($cdom,$cnum,$chome);
10959:     if (!$cid) {
10960: 	unless ($cid=$env{'request.course.id'}) {
10961: 	    return 'not_in_class';
10962: 	}
10963: 	$cdom=$env{'course.'.$cid.'.domain'};
10964: 	$cnum=$env{'course.'.$cid.'.num'};
10965:     } else {
10966: 	($cdom,$cnum)=split(/_/,$cid);
10967:     }
10968:     $chome=$env{'course.'.$cid.'.home'};
10969:     if (!$chome) {
10970: 	$chome=&homeserver($cnum,$cdom);
10971:     }
10972:     if (!$chome) { return 'unknown_course'; }
10973:     # Make sure the user exists
10974:     my $uhome=&homeserver($uname,$udom);
10975:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
10976: 	return 'error: no such user';
10977:     }
10978:     # Get student data if we were not given enough information
10979:     if (!defined($first)  || $first  eq '' || 
10980:         !defined($last)   || $last   eq '' || 
10981:         !defined($uid)    || $uid    eq '' || 
10982:         !defined($middle) || $middle eq '' || 
10983:         !defined($gene)   || $gene   eq '') {
10984:         # They did not supply us with enough data to enroll the student, so
10985:         # we need to pick up more information.
10986:         my %tmp = &get('environment',
10987:                        ['firstname','middlename','lastname', 'generation','id']
10988:                        ,$udom,$uname);
10989: 
10990:         #foreach my $key (keys(%tmp)) {
10991:         #    &logthis("key $key = ".$tmp{$key});
10992:         #}
10993:         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
10994:         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
10995:         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
10996:         $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
10997:         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
10998:     }
10999:     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
11000:     my $user = "$uname:$udom";
11001:     my %old_entry = &get('classlist',[$user],$cdom,$cnum);
11002:     my $reply=cput('classlist',
11003: 		   {$user => 
11004: 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
11005: 		   $cdom,$cnum);
11006:     if (($reply eq 'ok') || ($reply eq 'delayed')) {
11007:         &devalidate_getsection_cache($udom,$uname,$cid);
11008:     } else { 
11009: 	return 'error: '.$reply;
11010:     }
11011:     # Add student role to user
11012:     my $uurl='/'.$cid;
11013:     $uurl=~s/\_/\//g;
11014:     if ($usec) {
11015: 	$uurl.='/'.$usec;
11016:     }
11017:     my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
11018:                              $selfenroll,$context);
11019:     if ($result ne 'ok') {
11020:         if ($old_entry{$user} ne '') {
11021:             $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
11022:         } else {
11023:             $reply = &del('classlist',[$user],$cdom,$cnum);
11024:         }
11025:     }
11026:     return $result; 
11027: }
11028: 
11029: sub format_name {
11030:     my ($firstname,$middlename,$lastname,$generation,$first)=@_;
11031:     my $name;
11032:     if ($first ne 'lastname') {
11033: 	$name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
11034:     } else {
11035: 	if ($lastname=~/\S/) {
11036: 	    $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
11037: 	    $name=~s/\s+,/,/;
11038: 	} else {
11039: 	    $name.= $firstname.' '.$middlename.' '.$generation;
11040: 	}
11041:     }
11042:     $name=~s/^\s+//;
11043:     $name=~s/\s+$//;
11044:     $name=~s/\s+/ /g;
11045:     return $name;
11046: }
11047: 
11048: # ------------------------------------------------- Write to course preferences
11049: 
11050: sub writecoursepref {
11051:     my ($courseid,%prefs)=@_;
11052:     $courseid=~s/^\///;
11053:     $courseid=~s/\_/\//g;
11054:     my ($cdomain,$cnum)=split(/\//,$courseid);
11055:     my $chome=homeserver($cnum,$cdomain);
11056:     if (($chome eq '') || ($chome eq 'no_host')) { 
11057: 	return 'error: no such course';
11058:     }
11059:     my $cstring='';
11060:     foreach my $pref (keys(%prefs)) {
11061: 	$cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
11062:     }
11063:     $cstring=~s/\&$//;
11064:     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
11065: }
11066: 
11067: # ---------------------------------------------------------- Make/modify course
11068: 
11069: sub createcourse {
11070:     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
11071:         $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
11072:     $url=&declutter($url);
11073:     my $cid='';
11074:     if ($context eq 'requestcourses') {
11075:         my $can_create = 0;
11076:         my ($ownername,$ownerdom) = split(':',$course_owner);
11077:         if ($udom eq $ownerdom) {
11078:             my $reload;
11079:             if (($callercontext eq 'auto') &&
11080:                ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
11081:                 $reload = 'reload';
11082:             }
11083:             if (&usertools_access($ownername,$ownerdom,$category,$reload,
11084:                                   $context)) {
11085:                 $can_create = 1;
11086:             }
11087:         } else {
11088:             my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
11089:                                            $category);
11090:             if ($userenv{'reqcrsotherdom.'.$category} ne '') {
11091:                 my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
11092:                 if (@curr > 0) {
11093:                     my @options = qw(approval validate autolimit);
11094:                     my $optregex = join('|',@options);
11095:                     if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
11096:                         $can_create = 1;
11097:                     }
11098:                 }
11099:             }
11100:         }
11101:         if ($can_create) {
11102:             unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
11103:                 unless (&allowed('ccc',$udom)) {
11104:                     return 'refused'; 
11105:                 }
11106:             }
11107:         } else {
11108:             return 'refused';
11109:         }
11110:     } elsif (!&allowed('ccc',$udom)) {
11111:         return 'refused';
11112:     }
11113: # --------------------------------------------------------------- Get Unique ID
11114:     my $uname;
11115:     if ($cnum =~ /^$match_courseid$/) {
11116:         my $chome=&homeserver($cnum,$udom,'true');
11117:         if (($chome eq '') || ($chome eq 'no_host')) {
11118:             $uname = $cnum;
11119:         } else {
11120:             $uname = &generate_coursenum($udom,$crstype);
11121:         }
11122:     } else {
11123:         $uname = &generate_coursenum($udom,$crstype);
11124:     }
11125:     return $uname if ($uname =~ /^error/);
11126: # -------------------------------------------------- Check supplied server name
11127:     if (!defined($course_server)) {
11128:         if (defined(&domain($udom,'primary'))) {
11129:             $course_server = &domain($udom,'primary');
11130:         } else {
11131:             $course_server = $env{'user.home'}; 
11132:         }
11133:     }
11134:     my %host_servers =
11135:         &get_servers($udom,'library');
11136:     unless ($host_servers{$course_server}) {
11137:         return 'error: invalid home server for course: '.$course_server;
11138:     }
11139: # ------------------------------------------------------------- Make the course
11140:     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
11141:                       $course_server);
11142:     unless ($reply eq 'ok') { return 'error: '.$reply; }
11143:     my $uhome=&homeserver($uname,$udom,'true');
11144:     if (($uhome eq '') || ($uhome eq 'no_host')) { 
11145: 	return 'error: no such course';
11146:     }
11147: # ----------------------------------------------------------------- Course made
11148: # log existence
11149:     my $now = time;
11150:     my $newcourse = {
11151:                     $udom.'_'.$uname => {
11152:                                      description => $description,
11153:                                      inst_code   => $inst_code,
11154:                                      owner       => $course_owner,
11155:                                      type        => $crstype,
11156:                                      creator     => $env{'user.name'}.':'.
11157:                                                     $env{'user.domain'},
11158:                                      created     => $now,
11159:                                      context     => $context,
11160:                                                 },
11161:                     };
11162:     &courseidput($udom,$newcourse,$uhome,'notime');
11163: # set toplevel url
11164:     my $topurl=$url;
11165:     unless ($nonstandard) {
11166: # ------------------------------------------ For standard courses, make top url
11167:         my $mapurl=&clutter($url);
11168:         if ($mapurl eq '/res/') { $mapurl=''; }
11169:         $env{'form.initmap'}=(<<ENDINITMAP);
11170: <map>
11171: <resource id="1" type="start"></resource>
11172: <resource id="2" src="$mapurl"></resource>
11173: <resource id="3" type="finish"></resource>
11174: <link index="1" from="1" to="2"></link>
11175: <link index="2" from="2" to="3"></link>
11176: </map>
11177: ENDINITMAP
11178:         $topurl=&declutter(
11179:         &finishuserfileupload($uname,$udom,'initmap','default.sequence')
11180:                           );
11181:     }
11182: # ----------------------------------------------------------- Write preferences
11183:     &writecoursepref($udom.'_'.$uname,
11184:                      ('description'              => $description,
11185:                       'url'                      => $topurl,
11186:                       'internal.creator'         => $env{'user.name'}.':'.
11187:                                                     $env{'user.domain'},
11188:                       'internal.created'         => $now,
11189:                       'internal.creationcontext' => $context)
11190:                     );
11191:     return '/'.$udom.'/'.$uname;
11192: }
11193: 
11194: # ------------------------------------------------------------------- Create ID
11195: sub generate_coursenum {
11196:     my ($udom,$crstype) = @_;
11197:     my $domdesc = &domain($udom);
11198:     return 'error: invalid domain' if ($domdesc eq '');
11199:     my $first;
11200:     if ($crstype eq 'Community') {
11201:         $first = '0';
11202:     } else {
11203:         $first = int(1+rand(9)); 
11204:     } 
11205:     my $uname=$first.
11206:         ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
11207:         substr($$.time,0,5).unpack("H8",pack("I32",time)).
11208:         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
11209: # ----------------------------------------------- Make sure that does not exist
11210:     my $uhome=&homeserver($uname,$udom,'true');
11211:     unless (($uhome eq '') || ($uhome eq 'no_host')) {
11212:         if ($crstype eq 'Community') {
11213:             $first = '0';
11214:         } else {
11215:             $first = int(1+rand(9));
11216:         }
11217:         $uname=$first.
11218:                ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
11219:                substr($$.time,0,5).unpack("H8",pack("I32",time)).
11220:                unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
11221:         $uhome=&homeserver($uname,$udom,'true');
11222:         unless (($uhome eq '') || ($uhome eq 'no_host')) {
11223:             return 'error: unable to generate unique course-ID';
11224:         }
11225:     }
11226:     return $uname;
11227: }
11228: 
11229: sub is_course {
11230:     my ($cdom, $cnum) = scalar(@_) == 1 ? 
11231:          ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
11232: 
11233:     return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
11234:     my $uhome=&homeserver($cnum,$cdom);
11235:     my $iscourse;
11236:     if (grep { $_ eq $uhome } current_machine_ids()) {
11237:         $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
11238:     } else {
11239:         my $hashid = $cdom.':'.$cnum;
11240:         ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
11241:         unless (defined($cached)) {
11242:             my %courses = &courseiddump($cdom, '.', 1, '.', '.',
11243:                                         $cnum,undef,undef,'.');
11244:             $iscourse = 0;
11245:             if (exists($courses{$cdom.'_'.$cnum})) {
11246:                 $iscourse = 1;
11247:             }
11248:             &do_cache_new('iscourse',$hashid,$iscourse,3600);
11249:         }
11250:     }
11251:     return unless ($iscourse);
11252:     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
11253: }
11254: 
11255: sub store_userdata {
11256:     my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
11257:     my $result;
11258:     if ($datakey ne '') {
11259:         if (ref($storehash) eq 'HASH') {
11260:             if ($udom eq '' || $uname eq '') {
11261:                 $udom = $env{'user.domain'};
11262:                 $uname = $env{'user.name'};
11263:             }
11264:             my $uhome=&homeserver($uname,$udom);
11265:             if (($uhome eq '') || ($uhome eq 'no_host')) {
11266:                 $result = 'error: no_host';
11267:             } else {
11268:                 $storehash->{'ip'} = &get_requestor_ip();
11269:                 $storehash->{'host'} = $perlvar{'lonHostID'};
11270: 
11271:                 my $namevalue='';
11272:                 foreach my $key (keys(%{$storehash})) {
11273:                     $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
11274:                 }
11275:                 $namevalue=~s/\&$//;
11276:                 unless ($namespace eq 'courserequests') {
11277:                     $datakey = &escape($datakey);
11278:                 }
11279:                 $result =  &reply("store:$udom:$uname:$namespace:$datakey:".
11280:                                   $namevalue,$uhome);
11281:             }
11282:         } else {
11283:             $result = 'error: data to store was not a hash reference'; 
11284:         }
11285:     } else {
11286:         $result= 'error: invalid requestkey'; 
11287:     }
11288:     return $result;
11289: }
11290: 
11291: # ---------------------------------------------------------- Assign Custom Role
11292: 
11293: sub assigncustomrole {
11294:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
11295:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
11296:                        $end,$start,$deleteflag,$selfenroll,$context);
11297: }
11298: 
11299: # ----------------------------------------------------------------- Revoke Role
11300: 
11301: sub revokerole {
11302:     my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
11303:     my $now=time;
11304:     return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
11305: }
11306: 
11307: # ---------------------------------------------------------- Revoke Custom Role
11308: 
11309: sub revokecustomrole {
11310:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
11311:     my $now=time;
11312:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
11313:            $deleteflag,$selfenroll,$context);
11314: }
11315: 
11316: # ------------------------------------------------------------ Disk usage
11317: sub diskusage {
11318:     my ($udom,$uname,$directorypath,$getpropath)=@_;
11319:     $directorypath =~ s/\/$//;
11320:     my $listing=&reply('du2:'.&escape($directorypath).':'
11321:                        .&escape($getpropath).':'.&escape($uname).':'
11322:                        .&escape($udom),homeserver($uname,$udom));
11323:     if ($listing eq 'unknown_cmd') {
11324:         if ($getpropath) {
11325:             $directorypath = &propath($udom,$uname).'/'.$directorypath; 
11326:         }
11327:         $listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
11328:     }
11329:     return $listing;
11330: }
11331: 
11332: sub is_locked {
11333:     my ($file_name, $domain, $user, $which) = @_;
11334:     my @check;
11335:     my $is_locked;
11336:     push (@check,$file_name);
11337:     my %locked = &get('file_permissions',\@check,
11338: 		      $env{'user.domain'},$env{'user.name'});
11339:     my ($tmp)=keys(%locked);
11340:     if ($tmp=~/^error:/) { undef(%locked); }
11341:     
11342:     if (ref($locked{$file_name}) eq 'ARRAY') {
11343:         $is_locked = 'false';
11344:         foreach my $entry (@{$locked{$file_name}}) {
11345:            if (ref($entry) eq 'ARRAY') {
11346:                $is_locked = 'true';
11347:                if (ref($which) eq 'ARRAY') {
11348:                    push(@{$which},$entry);
11349:                } else {
11350:                    last;
11351:                }
11352:            }
11353:        }
11354:     } else {
11355:         $is_locked = 'false';
11356:     }
11357:     return $is_locked;
11358: }
11359: 
11360: sub declutter_portfile {
11361:     my ($file) = @_;
11362:     $file =~ s{^(/portfolio/|portfolio/)}{/};
11363:     return $file;
11364: }
11365: 
11366: # ------------------------------------------------------------- Mark as Read Only
11367: 
11368: sub mark_as_readonly {
11369:     my ($domain,$user,$files,$what) = @_;
11370:     my %current_permissions = &dump('file_permissions',$domain,$user);
11371:     my ($tmp)=keys(%current_permissions);
11372:     if ($tmp=~/^error:/) { undef(%current_permissions); }
11373:     foreach my $file (@{$files}) {
11374: 	$file = &declutter_portfile($file);
11375:         push(@{$current_permissions{$file}},$what);
11376:     }
11377:     &put('file_permissions',\%current_permissions,$domain,$user);
11378:     return;
11379: }
11380: 
11381: # ------------------------------------------------------------Save Selected Files
11382: 
11383: sub save_selected_files {
11384:     my ($user, $path, @files) = @_;
11385:     my $filename = $user."savedfiles";
11386:     my @other_files = &files_not_in_path($user, $path);
11387:     open (OUT,'>',LONCAPA::tempdir().$filename);
11388:     foreach my $file (@files) {
11389:         print (OUT $env{'form.currentpath'}.$file."\n");
11390:     }
11391:     foreach my $file (@other_files) {
11392:         print (OUT $file."\n");
11393:     }
11394:     close (OUT);
11395:     return 'ok';
11396: }
11397: 
11398: sub clear_selected_files {
11399:     my ($user) = @_;
11400:     my $filename = $user."savedfiles";
11401:     open (OUT,'>',LONCAPA::tempdir().$filename);
11402:     print (OUT undef);
11403:     close (OUT);
11404:     return ("ok");    
11405: }
11406: 
11407: sub files_in_path {
11408:     my ($user, $path) = @_;
11409:     my $filename = $user."savedfiles";
11410:     my %return_files;
11411:     open (IN,'<',LONCAPA::tempdir().$filename);
11412:     while (my $line_in = <IN>) {
11413:         chomp ($line_in);
11414:         my @paths_and_file = split (m!/!, $line_in);
11415:         my $file_part = pop (@paths_and_file);
11416:         my $path_part = join ('/', @paths_and_file);
11417:         $path_part.='/';
11418:         my $path_and_file = $path_part.$file_part;
11419:         if ($path_part eq $path) {
11420:             $return_files{$file_part}= 'selected';
11421:         }
11422:     }
11423:     close (IN);
11424:     return (\%return_files);
11425: }
11426: 
11427: # called in portfolio select mode, to show files selected NOT in current directory
11428: sub files_not_in_path {
11429:     my ($user, $path) = @_;
11430:     my $filename = $user."savedfiles";
11431:     my @return_files;
11432:     my $path_part;
11433:     open(IN, '<',LONCAPA::tempdir().$filename);
11434:     while (my $line = <IN>) {
11435:         #ok, I know it's clunky, but I want it to work
11436:         my @paths_and_file = split(m|/|, $line);
11437:         my $file_part = pop(@paths_and_file);
11438:         chomp($file_part);
11439:         my $path_part = join('/', @paths_and_file);
11440:         $path_part .= '/';
11441:         my $path_and_file = $path_part.$file_part;
11442:         if ($path_part ne $path) {
11443:             push(@return_files, ($path_and_file));
11444:         }
11445:     }
11446:     close(OUT);
11447:     return (@return_files);
11448: }
11449: 
11450: #------------------------------Submitted/Handedback Portfolio Files Versioning
11451:  
11452: sub portfiles_versioning {
11453:     my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_;
11454:     my $portfolio_root = '/userfiles/portfolio';
11455:     return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY'));
11456:     foreach my $file (@{$portfiles}) {
11457:         &unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file);
11458:         my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/);
11459:         my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file);
11460:         my $getpropath = 1;
11461:         my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain,
11462:                                              $stu_name,$getpropath);
11463:         my $version = &get_next_version($answer_name,$answer_ext,$dir_list);
11464:         my $new_answer = 
11465:             &version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version);
11466:         if ($new_answer ne 'problem getting file') {
11467:             push(@{$versioned_portfiles}, $directory.$new_answer);
11468:             &mark_as_readonly($domain,$stu_name,[$directory.$new_answer],
11469:                               [$symb,$env{'request.course.id'},'graded']);
11470:         }
11471:     }
11472: }
11473: 
11474: sub get_next_version {
11475:     my ($answer_name, $answer_ext, $dir_list) = @_;
11476:     my $version;
11477:     if (ref($dir_list) eq 'ARRAY') {
11478:         foreach my $row (@{$dir_list}) {
11479:             my ($file) = split(/\&/,$row,2);
11480:             my ($file_name,$file_version,$file_ext) =
11481:                 &file_name_version_ext($file);
11482:             if (($file_name eq $answer_name) &&
11483:                 ($file_ext eq $answer_ext)) {
11484:                      # gets here if filename and extension match,
11485:                      # regardless of version
11486:                 if ($file_version ne '') {
11487:                     # a versioned file is found  so save it for later
11488:                     if ($file_version > $version) {
11489:                         $version = $file_version;
11490:                     }
11491:                 }
11492:             }
11493:         }
11494:     }
11495:     $version ++;
11496:     return($version);
11497: }
11498: 
11499: sub version_selected_portfile {
11500:     my ($domain,$stu_name,$directory,$file_name,$version) = @_;
11501:     my ($answer_name,$answer_ver,$answer_ext) =
11502:         &file_name_version_ext($file_name);
11503:     my $new_answer;
11504:     $env{'form.copy'} =
11505:         &getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name");
11506:     if($env{'form.copy'} eq '-1') {
11507:         $new_answer = 'problem getting file';
11508:     } else {
11509:         $new_answer = $answer_name.'.'.$version.'.'.$answer_ext;
11510:         my $copy_result = 
11511:             &finishuserfileupload($stu_name,$domain,'copy',
11512:                                   '/portfolio'.$directory.$new_answer);
11513:     }
11514:     undef($env{'form.copy'});
11515:     return ($new_answer);
11516: }
11517: 
11518: sub file_name_version_ext {
11519:     my ($file)=@_;
11520:     my @file_parts = split(/\./, $file);
11521:     my ($name,$version,$ext);
11522:     if (@file_parts > 1) {
11523:         $ext=pop(@file_parts);
11524:         if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) {
11525:             $version=pop(@file_parts);
11526:         }
11527:         $name=join('.',@file_parts);
11528:     } else {
11529:         $name=join('.',@file_parts);
11530:     }
11531:     return($name,$version,$ext);
11532: }
11533: 
11534: #----------------------------------------------Get portfolio file permissions
11535: 
11536: sub get_portfile_permissions {
11537:     my ($domain,$user) = @_;
11538:     my %current_permissions = &dump('file_permissions',$domain,$user);
11539:     my ($tmp)=keys(%current_permissions);
11540:     if ($tmp=~/^error:/) { undef(%current_permissions); }
11541:     return \%current_permissions;
11542: }
11543: 
11544: #---------------------------------------------Get portfolio file access controls
11545: 
11546: sub get_access_controls {
11547:     my ($current_permissions,$group,$file) = @_;
11548:     my %access;
11549:     my $real_file = $file;
11550:     $file =~ s/\.meta$//;
11551:     if (defined($file)) {
11552:         if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
11553:             foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
11554:                 $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
11555:             }
11556:         }
11557:     } else {
11558:         foreach my $key (keys(%{$current_permissions})) {
11559:             if ($key =~ /\0accesscontrol$/) {
11560:                 if (defined($group)) {
11561:                     if ($key !~ m-^\Q$group\E/-) {
11562:                         next;
11563:                     }
11564:                 }
11565:                 my ($fullpath) = split(/\0/,$key);
11566:                 if (ref($$current_permissions{$key}) eq 'HASH') {
11567:                     foreach my $control (keys(%{$$current_permissions{$key}})) {
11568:                         $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
11569:                     }
11570:                 }
11571:             }
11572:         }
11573:     }
11574:     return %access;
11575: }
11576: 
11577: sub modify_access_controls {
11578:     my ($file_name,$changes,$domain,$user)=@_;
11579:     my ($outcome,$deloutcome);
11580:     my %store_permissions;
11581:     my %new_values;
11582:     my %new_control;
11583:     my %translation;
11584:     my @deletions = ();
11585:     my $now = time;
11586:     if (exists($$changes{'activate'})) {
11587:         if (ref($$changes{'activate'}) eq 'HASH') {
11588:             my @newitems = sort(keys(%{$$changes{'activate'}}));
11589:             my $numnew = scalar(@newitems);
11590:             for (my $i=0; $i<$numnew; $i++) {
11591:                 my $newkey = $newitems[$i];
11592:                 my $newid = &Apache::loncommon::get_cgi_id();
11593:                 if ($newkey =~ /^\d+:/) { 
11594:                     $newkey =~ s/^(\d+)/$newid/;
11595:                     $translation{$1} = $newid;
11596:                 } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
11597:                     $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
11598:                     $translation{$1} = $newid;
11599:                 }
11600:                 $new_values{$file_name."\0".$newkey} = 
11601:                                           $$changes{'activate'}{$newitems[$i]};
11602:                 $new_control{$newkey} = $now;
11603:             }
11604:         }
11605:     }
11606:     my %todelete;
11607:     my %changed_items;
11608:     foreach my $action ('delete','update') {
11609:         if (exists($$changes{$action})) {
11610:             if (ref($$changes{$action}) eq 'HASH') {
11611:                 foreach my $key (keys(%{$$changes{$action}})) {
11612:                     my ($itemnum) = ($key =~ /^([^:]+):/);
11613:                     if ($action eq 'delete') { 
11614:                         $todelete{$itemnum} = 1;
11615:                     } else {
11616:                         $changed_items{$itemnum} = $key;
11617:                     }
11618:                 }
11619:             }
11620:         }
11621:     }
11622:     # get lock on access controls for file.
11623:     my $lockhash = {
11624:                   $file_name."\0".'locked_access_records' => $env{'user.name'}.
11625:                                                        ':'.$env{'user.domain'},
11626:                    }; 
11627:     my $tries = 0;
11628:     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
11629:    
11630:     while (($gotlock ne 'ok') && $tries < 10) {
11631:         $tries ++;
11632:         sleep(0.1);
11633:         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
11634:     }
11635:     if ($gotlock eq 'ok') {
11636:         my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
11637:         my ($tmp)=keys(%curr_permissions);
11638:         if ($tmp=~/^error:/) { undef(%curr_permissions); }
11639:         if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
11640:             my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
11641:             if (ref($curr_controls) eq 'HASH') {
11642:                 foreach my $control_item (keys(%{$curr_controls})) {
11643:                     my ($itemnum) = ($control_item =~ /^([^:]+):/);
11644:                     if (defined($todelete{$itemnum})) {
11645:                         push(@deletions,$file_name."\0".$control_item);
11646:                     } else {
11647:                         if (defined($changed_items{$itemnum})) {
11648:                             $new_control{$changed_items{$itemnum}} = $now;
11649:                             push(@deletions,$file_name."\0".$control_item);
11650:                             $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
11651:                         } else {
11652:                             $new_control{$control_item} = $$curr_controls{$control_item};
11653:                         }
11654:                     }
11655:                 }
11656:             }
11657:         }
11658:         my ($group);
11659:         if (&is_course($domain,$user)) {
11660:             ($group,my $file) = split(/\//,$file_name,2);
11661:         }
11662:         $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
11663:         $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
11664:         $outcome = &put('file_permissions',\%new_values,$domain,$user);
11665:         #  remove lock
11666:         my @del_lock = ($file_name."\0".'locked_access_records');
11667:         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
11668:         my $sqlresult =
11669:             &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
11670:                                     $group);
11671:     } else {
11672:         $outcome = "error: could not obtain lockfile\n";  
11673:     }
11674:     return ($outcome,$deloutcome,\%new_values,\%translation);
11675: }
11676: 
11677: sub make_public_indefinitely {
11678:     my (@requrl) = @_;
11679:     return &automated_portfile_access('public',\@requrl);
11680: }
11681: 
11682: sub automated_portfile_access {
11683:     my ($accesstype,$addsref,$delsref,$info) = @_;
11684:     unless (($accesstype eq 'public') || ($accesstype eq 'ip')) {
11685:         return 'invalid';
11686:     }
11687:     my %urls;
11688:     if (ref($addsref) eq 'ARRAY') {
11689:         foreach my $requrl (@{$addsref}) {
11690:             if (&is_portfolio_url($requrl)) {
11691:                 unless (exists($urls{$requrl})) {
11692:                     $urls{$requrl} = 'add';
11693:                 }
11694:             }
11695:         }
11696:     }
11697:     if (ref($delsref) eq 'ARRAY') {
11698:         foreach my $requrl (@{$delsref}) { 
11699:             if (&is_portfolio_url($requrl)) {
11700:                 unless (exists($urls{$requrl})) {
11701:                     $urls{$requrl} = 'delete'; 
11702:                 }
11703:             }
11704:         }
11705:     }
11706:     unless (keys(%urls)) {
11707:         return 'invalid';
11708:     }
11709:     my $ip;
11710:     if ($accesstype eq 'ip') {
11711:         if (ref($info) eq 'HASH') {
11712:             if ($info->{'ip'} ne '') {
11713:                 $ip = $info->{'ip'};
11714:             }
11715:         }
11716:         if ($ip eq '') {
11717:             return 'invalid';
11718:         }
11719:     }
11720:     my $errors;
11721:     my $now = time;
11722:     my %current_perms;
11723:     foreach my $requrl (sort(keys(%urls))) {
11724:         my $action;
11725:         if ($urls{$requrl} eq 'add') {
11726:             $action = 'activate';
11727:         } else {
11728:             $action = 'none';
11729:         }
11730:         my $aclnum = 0;
11731:         my (undef,$udom,$unum,$file_name,$group) =
11732:             &parse_portfolio_url($requrl);
11733:         unless (exists($current_perms{$unum.':'.$udom})) {
11734:             $current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum);
11735:         }
11736:         my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom},
11737:                                                    $group,$file_name);
11738:         foreach my $key (keys(%{$access_controls{$file_name}})) {
11739:             my ($num,$scope,$end,$start) = 
11740:                 ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
11741:             if ($scope eq $accesstype) {
11742:                 if (($start <= $now) && ($end == 0)) {
11743:                     if ($accesstype eq 'ip') {
11744:                         if (ref($access_controls{$file_name}{$key}) eq 'HASH') {
11745:                             if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') {
11746:                                 if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) {
11747:                                     if ($urls{$requrl} eq 'add') {
11748:                                         $action = 'none';
11749:                                         last;
11750:                                     } else {
11751:                                         $action = 'delete';
11752:                                         $aclnum = $num;
11753:                                         last;
11754:                                     }
11755:                                 }
11756:                             }
11757:                         }
11758:                     } elsif ($accesstype eq 'public') {
11759:                         if ($urls{$requrl} eq 'add') {
11760:                             $action = 'none';
11761:                             last;
11762:                         } else {
11763:                             $action = 'delete';
11764:                             $aclnum = $num;
11765:                             last;
11766:                         }
11767:                     }
11768:                 } elsif ($accesstype eq 'public') {
11769:                     $action = 'update';
11770:                     $aclnum = $num;
11771:                     last;
11772:                 }
11773:             }
11774:         }
11775:         if ($action eq 'none') {
11776:             next;
11777:         } else {
11778:             my %changes;
11779:             my $newend = 0;
11780:             my $newstart = $now;
11781:             my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart;
11782:             $changes{$action}{$newkey} = {
11783:                 type => $accesstype,
11784:                 time => {
11785:                     start => $newstart,
11786:                     end   => $newend,
11787:                 },
11788:             };
11789:             if ($accesstype eq 'ip') {
11790:                 $changes{$action}{$newkey}{'ip'} = [$ip];
11791:             }
11792:             my ($outcome,$deloutcome,$new_values,$translation) =
11793:                 &modify_access_controls($file_name,\%changes,$udom,$unum);
11794:             unless ($outcome eq 'ok') {
11795:                 $errors .= $outcome.' ';
11796:             }
11797:         }
11798:     }
11799:     if ($errors) {
11800:         $errors =~ s/\s$//;
11801:         return $errors;
11802:     } else {
11803:         return 'ok';
11804:     }
11805: }
11806: 
11807: #------------------------------------------------------Get Marked as Read Only
11808: 
11809: sub get_marked_as_readonly {
11810:     my ($domain,$user,$what,$group) = @_;
11811:     my $current_permissions = &get_portfile_permissions($domain,$user);
11812:     my @readonly_files;
11813:     my $cmp1=$what;
11814:     if (ref($what)) { $cmp1=join('',@{$what}) };
11815:     while (my ($file_name,$value) = each(%{$current_permissions})) {
11816:         if (defined($group)) {
11817:             if ($file_name !~ m-^\Q$group\E/-) {
11818:                 next;
11819:             }
11820:         }
11821:         if (ref($value) eq "ARRAY"){
11822:             foreach my $stored_what (@{$value}) {
11823:                 my $cmp2=$stored_what;
11824:                 if (ref($stored_what) eq 'ARRAY') {
11825:                     $cmp2=join('',@{$stored_what});
11826:                 }
11827:                 if ($cmp1 eq $cmp2) {
11828:                     push(@readonly_files, $file_name);
11829:                     last;
11830:                 } elsif (!defined($what)) {
11831:                     push(@readonly_files, $file_name);
11832:                     last;
11833:                 }
11834:             }
11835:         }
11836:     }
11837:     return @readonly_files;
11838: }
11839: #-----------------------------------------------------------Get Marked as Read Only Hash
11840: 
11841: sub get_marked_as_readonly_hash {
11842:     my ($current_permissions,$group,$what) = @_;
11843:     my %readonly_files;
11844:     while (my ($file_name,$value) = each(%{$current_permissions})) {
11845:         if (defined($group)) {
11846:             if ($file_name !~ m-^\Q$group\E/-) {
11847:                 next;
11848:             }
11849:         }
11850:         if (ref($value) eq "ARRAY"){
11851:             foreach my $stored_what (@{$value}) {
11852:                 if (ref($stored_what) eq 'ARRAY') {
11853:                     foreach my $lock_descriptor(@{$stored_what}) {
11854:                         if ($lock_descriptor eq 'graded') {
11855:                             $readonly_files{$file_name} = 'graded';
11856:                         } elsif ($lock_descriptor eq 'handback') {
11857:                             $readonly_files{$file_name} = 'handback';
11858:                         } else {
11859:                             if (!exists($readonly_files{$file_name})) {
11860:                                 $readonly_files{$file_name} = 'locked';
11861:                             }
11862:                         }
11863:                     }
11864:                 } 
11865:             }
11866:         } 
11867:     }
11868:     return %readonly_files;
11869: }
11870: # ------------------------------------------------------------ Unmark as Read Only
11871: 
11872: sub unmark_as_readonly {
11873:     # unmarks $file_name (if $file_name is defined), or all files locked by $what 
11874:     # for portfolio submissions, $what contains [$symb,$crsid] 
11875:     my ($domain,$user,$what,$file_name,$group) = @_;
11876:     $file_name = &declutter_portfile($file_name);
11877:     my $symb_crs = $what;
11878:     if (ref($what)) { $symb_crs=join('',@$what); }
11879:     my %current_permissions = &dump('file_permissions',$domain,$user,$group);
11880:     my ($tmp)=keys(%current_permissions);
11881:     if ($tmp=~/^error:/) { undef(%current_permissions); }
11882:     my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
11883:     foreach my $file (@readonly_files) {
11884: 	my $clean_file = &declutter_portfile($file);
11885: 	if (defined($file_name) && ($file_name ne $clean_file)) { next; }
11886: 	my $current_locks = $current_permissions{$file};
11887:         my @new_locks;
11888:         my @del_keys;
11889:         if (ref($current_locks) eq "ARRAY"){
11890:             foreach my $locker (@{$current_locks}) {
11891:                 my $compare=$locker;
11892:                 if (ref($locker) eq 'ARRAY') {
11893:                     $compare=join('',@{$locker});
11894:                     if ($compare ne $symb_crs) {
11895:                         push(@new_locks, $locker);
11896:                     }
11897:                 }
11898:             }
11899:             if (scalar(@new_locks) > 0) {
11900:                 $current_permissions{$file} = \@new_locks;
11901:             } else {
11902:                 push(@del_keys, $file);
11903:                 &del('file_permissions',\@del_keys, $domain, $user);
11904:                 delete($current_permissions{$file});
11905:             }
11906:         }
11907:     }
11908:     &put('file_permissions',\%current_permissions,$domain,$user);
11909:     return;
11910: }
11911: 
11912: # ------------------------------------------------------------ Directory lister
11913: 
11914: sub dirlist {
11915:     my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;
11916:     $uri=~s/^\///;
11917:     $uri=~s/\/$//;
11918:     my ($udom, $uname);
11919:     if ($getuserdir) {
11920:         $udom = $userdomain;
11921:         $uname = $username;
11922:     } else {
11923:         (undef,$udom,$uname)=split(/\//,$uri);
11924:         if(defined($userdomain)) {
11925:             $udom = $userdomain;
11926:         }
11927:         if(defined($username)) {
11928:             $uname = $username;
11929:         }
11930:     }
11931:     my ($dirRoot,$listing,@listing_results);
11932: 
11933:     $dirRoot = $perlvar{'lonDocRoot'};
11934:     if (defined($getpropath)) {
11935:         $dirRoot = &propath($udom,$uname);
11936:         $dirRoot =~ s/\/$//;
11937:     } elsif (defined($getuserdir)) {
11938:         my $subdir=$uname.'__';
11939:         $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
11940:         $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
11941:                    ."/$udom/$subdir/$uname";
11942:     } elsif (defined($alternateRoot)) {
11943:         $dirRoot = $alternateRoot;
11944:     }
11945: 
11946:     if($udom) {
11947:         if($uname) {
11948:             my $uhome = &homeserver($uname,$udom);
11949:             if ($uhome eq 'no_host') {
11950:                 return ([],'no_host');
11951:             }
11952:             $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
11953:                               .$getuserdir.':'.&escape($dirRoot)
11954:                               .':'.&escape($uname).':'.&escape($udom),$uhome);
11955:             if ($listing eq 'unknown_cmd') {
11956:                 $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome);
11957:             } else {
11958:                 @listing_results = map { &unescape($_); } split(/:/,$listing);
11959:             }
11960:             if ($listing eq 'unknown_cmd') {
11961:                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome);
11962:                 @listing_results = split(/:/,$listing);
11963:             } else {
11964:                 @listing_results = map { &unescape($_); } split(/:/,$listing);
11965:             }
11966:             if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || 
11967:                 ($listing eq 'rejected') || ($listing eq 'refused') ||
11968:                 ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
11969:                 return ([],$listing);
11970:             } else {
11971:                 return (\@listing_results);
11972:             }
11973:         } elsif(!$alternateRoot) {
11974:             my (%allusers,%listerror);
11975: 	    my %servers = &get_servers($udom,'library');
11976:  	    foreach my $tryserver (keys(%servers)) {
11977:                 $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
11978:                                   &escape($udom),$tryserver);
11979:                 if ($listing eq 'unknown_cmd') {
11980: 		    $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
11981: 				      $udom, $tryserver);
11982:                 } else {
11983:                     @listing_results = map { &unescape($_); } split(/:/,$listing);
11984:                 }
11985: 		if ($listing eq 'unknown_cmd') {
11986: 		    $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
11987: 				      $udom, $tryserver);
11988: 		    @listing_results = split(/:/,$listing);
11989: 		} else {
11990: 		    @listing_results =
11991: 			map { &unescape($_); } split(/:/,$listing);
11992: 		}
11993:                 if (($listing eq 'no_such_host') || ($listing eq 'con_lost') ||
11994:                     ($listing eq 'rejected') || ($listing eq 'refused') ||
11995:                     ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
11996:                     $listerror{$tryserver} = $listing;
11997:                 } else {
11998: 		    foreach my $line (@listing_results) {
11999: 			my ($entry) = split(/&/,$line,2);
12000: 			$allusers{$entry} = 1;
12001: 		    }
12002: 		}
12003:             }
12004:             my @alluserslist=();
12005:             foreach my $user (sort(keys(%allusers))) {
12006:                 push(@alluserslist,$user.'&user');
12007:             }
12008: 
12009:             if (!%listerror) {
12010:                 # no errors
12011:                 return (\@alluserslist);
12012:             } elsif (scalar(keys(%servers)) == 1) {
12013:                 # one library server, one error 
12014:                 my ($key) = keys(%listerror);
12015:                 return (\@alluserslist, $listerror{$key});
12016:             } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
12017:                 # con_lost indicates that we might miss data from at least one
12018:                 # library server
12019:                 return (\@alluserslist, 'con_lost');
12020:             } else {
12021:                 # multiple library servers and no con_lost -> data should be
12022:                 # complete. 
12023:                 return (\@alluserslist);
12024:             }
12025: 
12026:         } else {
12027:             return ([],'missing username');
12028:         }
12029:     } elsif(!defined($getpropath)) {
12030:         my $path = $perlvar{'lonDocRoot'}.'/res/'; 
12031:         my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains()));
12032:         return (\@all_domains);
12033:     } else {
12034:         return ([],'missing domain');
12035:     }
12036: }
12037: 
12038: # --------------------------------------------- GetFileTimestamp
12039: # This function utilizes dirlist and returns the date stamp for
12040: # when it was last modified.  It will also return an error of -1
12041: # if an error occurs
12042: 
12043: sub GetFileTimestamp {
12044:     my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
12045:     $studentDomain = &LONCAPA::clean_domain($studentDomain);
12046:     $studentName   = &LONCAPA::clean_username($studentName);
12047:     my ($fileref,$error) = &dirlist($filename,$studentDomain,$studentName,
12048:                                     undef,$getuserdir);
12049:     if (($error eq 'empty') || ($error eq 'no_such_dir')) {
12050:         return -1;
12051:     }
12052:     if (ref($fileref) eq 'ARRAY') {
12053:         my @stats = split('&',$fileref->[0]);
12054:         # @stats contains first the filename, then the stat output
12055:         return $stats[10]; # so this is 10 instead of 9.
12056:     } else {
12057:         return -1;
12058:     }
12059: }
12060: 
12061: sub stat_file {
12062:     my ($uri) = @_;
12063:     $uri = &clutter_with_no_wrapper($uri);
12064: 
12065:     my ($udom,$uname,$file);
12066:     if ($uri =~ m-^/(uploaded|editupload)/-) {
12067: 	($udom,$uname,$file) =
12068: 	    ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
12069: 	$file = 'userfiles/'.$file;
12070:     }
12071:     if ($uri =~ m-^/res/-) {
12072: 	($udom,$uname) = 
12073: 	    ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
12074: 	$file = $uri;
12075:     }
12076: 
12077:     if (!$udom || !$uname || !$file) {
12078: 	# unable to handle the uri
12079: 	return ();
12080:     }
12081:     my $getpropath;
12082:     if ($file =~ /^userfiles\//) {
12083:         $getpropath = 1;
12084:     }
12085:     my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath);
12086:     if (($error eq 'empty') || ($error eq 'no_such_dir')) {
12087:         return ();
12088:     } else {
12089:         if (ref($listref) eq 'ARRAY') {
12090:             my @stats = split('&',$listref->[0]);
12091: 	    shift(@stats); #filename is first
12092: 	    return @stats;
12093:         }
12094:     }
12095:     return ();
12096: }
12097: 
12098: # --------------------------------------------------------- recursedirs
12099: # Recursive function to traverse either a specific user's Authoring Space
12100: # or corresponding Published Resource Space, and populate the hash ref:
12101: # $dirhashref with URLs of all directories, and if $filehashref hash
12102: # ref arg is provided, the URLs of any files, excluding versioned, .meta,
12103: # or .rights files in resource space, and .meta, .save, .log, .bak and
12104: # .rights files in Authoring Space.
12105: #
12106: # Inputs:
12107: #
12108: # $is_home - true if current server is home server for user's space
12109: # $recurse - if true will also traverse subdirectories recursively
12110: # $include - reference to hash containing allowed file extensions.  If provided,
12111: #             files which do not have a matching extension will be ignored.
12112: # $exclude - reference to hash containing excluded file extensions.  If provided,
12113: #             files which have a matching extension will be ignored.
12114: # $nonemptydir - if true, will only populate $fileshashref hash entry for a particular
12115: #             directory with first file found (with acceptable extension).
12116: # $addtopdir - if true, set $dirhashref->{'/'} = 1 
12117: # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
12118: # $relpath - Current path (relative to top level).
12119: # $dirhashref - reference to hash to populate with URLs of directories (Required)
12120: # $filehashref - reference to hash to populate with URLs of files (Optional)
12121: #
12122: # Returns: nothing
12123: #
12124: # Side Effects: populates $dirhashref, and $filehashref (if provided).
12125: #
12126: # Currently used by interface/londocs.pm to create linked select boxes for
12127: # directory and filename to import a Course "Author" resource into a course, and
12128: # also to create linked select boxes for Authoring Space and Directory to choose
12129: # save location for creation of a new "standard" problem from the Course Editor.
12130: #
12131: 
12132: sub recursedirs {
12133:     my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
12134:     return unless (ref($dirhashref) eq 'HASH');
12135:     my $docroot = $perlvar{'lonDocRoot'};
12136:     my $currpath = $docroot.$toppath;
12137:     if ($relpath ne '') {
12138:         $currpath .= "/$relpath";
12139:     }
12140:     my ($savefile,$checkinc,$checkexc);
12141:     if (ref($filehashref)) {
12142:         $savefile = 1;
12143:     }
12144:     if (ref($include) eq 'HASH') {
12145:         $checkinc = 1;
12146:     }
12147:     if (ref($exclude) eq 'HASH') {
12148:         $checkexc = 1;
12149:     }
12150:     if ($is_home) {
12151:         if ((-e $currpath) && (opendir(my $dirh,$currpath))) {
12152:             my $filecount = 0;
12153:             foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
12154:                 next if ($item eq '');
12155:                 if (-d "$currpath/$item") {
12156:                     my $newpath;
12157:                     if ($relpath ne '') {
12158:                         $newpath = "$relpath/$item";
12159:                     } else {
12160:                         $newpath = $item;
12161:                     }
12162:                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
12163:                     if ($recurse) {
12164:                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
12165:                     }
12166:                 } elsif (($savefile) || ($relpath eq '')) {
12167:                     next if ($nonemptydir && $filecount);
12168:                     if ($checkinc || $checkexc) {
12169:                         my ($extension) = ($item =~ /\.(\w+)$/);
12170:                         if ($checkinc) {
12171:                             next unless ($extension && $include->{$extension});
12172:                         }
12173:                         if ($checkexc) {
12174:                             next if ($extension && $exclude->{$extension});
12175:                         }
12176:                     }
12177:                     if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
12178:                         $dirhashref->{'/'} = 1;
12179:                     }
12180:                     if ($savefile) {
12181:                         if ($relpath eq '') {
12182:                             $filehashref->{'/'}{$item} = 1;
12183:                         } else {
12184:                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
12185:                         }
12186:                     }
12187:                     $filecount ++;
12188:                 }
12189:             }
12190:             closedir($dirh);
12191:         }
12192:     } else {
12193:         my ($dirlistref,$listerror) =
12194:             &dirlist($toppath.$relpath);
12195:         my @dir_lines;
12196:         my $dirptr=16384;
12197:         if (ref($dirlistref) eq 'ARRAY') {
12198:             my $filecount = 0;
12199:             foreach my $dir_line (sort
12200:                               {
12201:                                   my ($afile)=split('&',$a,2);
12202:                                   my ($bfile)=split('&',$b,2);
12203:                                   return (lc($afile) cmp lc($bfile));
12204:                               } (@{$dirlistref})) {
12205:                 my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) =
12206:                     split(/\&/,$dir_line,16);
12207:                 $item =~ s/\s+$//;
12208:                 next if (($item =~ /^\.\.?$/) || ($obs));
12209:                 if ($dirptr&$testdir) {
12210:                     my $newpath;
12211:                     if ($relpath) {
12212:                         $newpath = "$relpath/$item";
12213:                     } else {
12214:                         $newpath = $item;
12215:                     }
12216:                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
12217:                     if ($recurse) {
12218:                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
12219:                     }
12220:                 } elsif (($savefile) || ($relpath eq '')) {
12221:                     next if ($nonemptydir && $filecount);
12222:                     if ($checkinc || $checkexc) {
12223:                         my $extension;
12224:                         if ($checkinc) {
12225:                             next unless ($extension && $include->{$extension});
12226:                         }
12227:                         if ($checkexc) {
12228:                             next if ($extension && $exclude->{$extension});
12229:                         }
12230:                     }
12231:                     if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
12232:                         $dirhashref->{'/'} = 1;
12233:                     }
12234:                     if ($savefile) {
12235:                         if ($relpath eq '') {
12236:                             $filehashref->{'/'}{$item} = 1;
12237:                         } else {
12238:                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
12239:                         }
12240:                     }
12241:                     $filecount ++; 
12242:                 }
12243:             }
12244:         }
12245:     }
12246:     if ($addtopdir) {
12247:         if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
12248:             $dirhashref->{'/'} = 1;
12249:         }
12250:     }
12251:     return;
12252: }
12253: 
12254: sub priv_exclude {
12255:     return {
12256:              meta => 1,
12257:              save => 1,
12258:              log => 1,
12259:              bak => 1,
12260:              rights => 1,
12261:              DS_Store => 1,
12262:            };
12263: }
12264: 
12265: # -------------------------------------------------------- Value of a Condition
12266: 
12267: # gets the value of a specific preevaluated condition
12268: #    stored in the string  $env{user.state.<cid>}
12269: # or looks up a condition reference in the bighash and if if hasn't
12270: # already been evaluated recurses into docondval to get the value of
12271: # the condition, then memoizing it to 
12272: #   $env{user.state.<cid>.<condition>}
12273: sub directcondval {
12274:     my $number=shift;
12275:     if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
12276: 	&Apache::lonuserstate::evalstate();
12277:     }
12278:     if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
12279: 	return $env{'user.state.'.$env{'request.course.id'}.".$number"};
12280:     } elsif ($number =~ /^_/) {
12281: 	my $sub_condition;
12282: 	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
12283: 		&GDBM_READER(),0640)) {
12284: 	    $sub_condition=$bighash{'conditions'.$number};
12285: 	    untie(%bighash);
12286: 	}
12287: 	my $value = &docondval($sub_condition);
12288: 	&appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
12289: 	return $value;
12290:     }
12291:     if ($env{'user.state.'.$env{'request.course.id'}}) {
12292:        return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
12293:     } else {
12294:        return 2;
12295:     }
12296: }
12297: 
12298: # get the collection of conditions for this resource
12299: sub condval {
12300:     my $condidx=shift;
12301:     my $allpathcond='';
12302:     foreach my $cond (split(/\|/,$condidx)) {
12303: 	if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
12304: 	    $allpathcond.=
12305: 		'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
12306: 	}
12307:     }
12308:     $allpathcond=~s/\|$//;
12309:     return &docondval($allpathcond);
12310: }
12311: 
12312: #evaluates an expression of conditions
12313: sub docondval {
12314:     my ($allpathcond) = @_;
12315:     my $result=0;
12316:     if ($env{'request.course.id'}
12317: 	&& defined($allpathcond)) {
12318: 	my $operand='|';
12319: 	my @stack;
12320: 	foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
12321: 	    if ($chunk eq '(') {
12322: 		push @stack,($operand,$result);
12323: 	    } elsif ($chunk eq ')') {
12324: 		my $before=pop @stack;
12325: 		if (pop @stack eq '&') {
12326: 		    $result=$result>$before?$before:$result;
12327: 		} else {
12328: 		    $result=$result>$before?$result:$before;
12329: 		}
12330: 	    } elsif (($chunk eq '&') || ($chunk eq '|')) {
12331: 		$operand=$chunk;
12332: 	    } else {
12333: 		my $new=directcondval($chunk);
12334: 		if ($operand eq '&') {
12335: 		    $result=$result>$new?$new:$result;
12336: 		} else {
12337: 		    $result=$result>$new?$result:$new;
12338: 		}
12339: 	    }
12340: 	}
12341:     }
12342:     return $result;
12343: }
12344: 
12345: # ---------------------------------------------------- Devalidate courseresdata
12346: 
12347: sub devalidatecourseresdata {
12348:     my ($coursenum,$coursedomain)=@_;
12349:     my $hashid=$coursenum.':'.$coursedomain;
12350:     &devalidate_cache_new('courseres',$hashid);
12351: }
12352: 
12353: 
12354: # --------------------------------------------------- Course Resourcedata Query
12355: #
12356: #  Parameters:
12357: #      $coursenum    - Number of the course.
12358: #      $coursedomain - Domain at which the course was created.
12359: #  Returns:
12360: #     A hash of the course parameters along (I think) with timestamps
12361: #     and version info.
12362: 
12363: sub get_courseresdata {
12364:     my ($coursenum,$coursedomain)=@_;
12365:     my $coursehom=&homeserver($coursenum,$coursedomain);
12366:     my $hashid=$coursenum.':'.$coursedomain;
12367:     my ($result,$cached)=&is_cached_new('courseres',$hashid);
12368:     my %dumpreply;
12369:     unless (defined($cached)) {
12370: 	%dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
12371: 	$result=\%dumpreply;
12372: 	my ($tmp) = keys(%dumpreply);
12373: 	if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
12374: 	    &do_cache_new('courseres',$hashid,$result,600);
12375: 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
12376: 	    return $tmp;
12377: 	} elsif ($tmp =~ /^(error)/) {
12378: 	    $result=undef;
12379: 	    &do_cache_new('courseres',$hashid,$result,600);
12380: 	}
12381:     }
12382:     return $result;
12383: }
12384: 
12385: sub devalidateuserresdata {
12386:     my ($uname,$udom)=@_;
12387:     my $hashid="$udom:$uname";
12388:     &devalidate_cache_new('userres',$hashid);
12389: }
12390: 
12391: sub get_userresdata {
12392:     my ($uname,$udom)=@_;
12393:     #most student don\'t have any data set, check if there is some data
12394:     if (&EXT_cache_status($udom,$uname)) { return undef; }
12395: 
12396:     my $hashid="$udom:$uname";
12397:     my ($result,$cached)=&is_cached_new('userres',$hashid);
12398:     if (!defined($cached)) {
12399: 	my %resourcedata=&dump('resourcedata',$udom,$uname);
12400: 	$result=\%resourcedata;
12401: 	&do_cache_new('userres',$hashid,$result,600);
12402:     }
12403:     my ($tmp)=keys(%$result);
12404:     if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
12405: 	return $result;
12406:     }
12407:     #error 2 occurs when the .db doesn't exist
12408:     if ($tmp!~/error: 2 /) {
12409:         if ((!defined($cached)) || ($tmp ne 'con_lost')) {
12410: 	    &logthis("<font color=\"blue\">WARNING:".
12411: 		     " Trying to get resource data for ".
12412: 		     $uname." at ".$udom.": ".
12413: 		     $tmp."</font>");
12414:         }
12415:     } elsif ($tmp=~/error: 2 /) {
12416: 	#&EXT_cache_set($udom,$uname);
12417: 	&do_cache_new('userres',$hashid,undef,600);
12418: 	undef($tmp); # not really an error so don't send it back
12419:     }
12420:     return $tmp;
12421: }
12422: #----------------------------------------------- resdata - return resource data
12423: #  Purpose:
12424: #    Return resource data for either users or for a course.
12425: #  Parameters:
12426: #     $name      - Course/user name.
12427: #     $domain    - Name of the domain the user/course is registered on.
12428: #     $type      - Type of thing $name is (must be 'course' or 'user')
12429: #     $mapp      - decluttered URL of enclosing map  
12430: #     $recursed  - Ref to scalar -- set to 1, if nested maps have been recursed.
12431: #     $recurseup - Ref to array of map URLs, starting with map containing
12432: #                  $mapp up through hierarchy of nested maps to top level map.  
12433: #     $courseid  - CourseID (first part of param identifier).
12434: #     $modifier  - Middle part of param identifier.
12435: #     $what      - Last part of param identifier.
12436: #     @which     - Array of names of resources desired.
12437: #  Returns:
12438: #     The value of the first reasource in @which that is found in the
12439: #     resource hash.
12440: #  Exceptional Conditions:
12441: #     If the $type passed in is not valid (not the string 'course' or 
12442: #     'user', an undefined  reference is returned.
12443: #     If none of the resources are found, an undef is returned
12444: sub resdata {
12445:     my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid,
12446:         $modifier,$what,@which)=@_;
12447:     my $result;
12448:     if ($type eq 'course') {
12449: 	$result=&get_courseresdata($name,$domain);
12450:     } elsif ($type eq 'user') {
12451: 	$result=&get_userresdata($name,$domain);
12452:     }
12453:     if (!ref($result)) { return $result; }    
12454:     foreach my $item (@which) {
12455:         if ($item->[1] eq 'course') {
12456:             if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) {
12457:                 unless ($$recursed) {
12458:                     @{$recurseup} = &get_map_hierarchy($mapp,$courseid);
12459:                     $$recursed = 1;
12460:                 }
12461:                 foreach my $item (@${recurseup}) {
12462:                     my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what;
12463:                     last if (defined($result->{$norecursechk}));
12464:                     my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what;
12465:                     if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; }
12466:                 }
12467:             }
12468:         }
12469:         if (defined($result->{$item->[0]})) {
12470: 	    return [$result->{$item->[0]},$item->[1]];
12471: 	}
12472:     }
12473:     return undef;
12474: }
12475: 
12476: sub get_domain_lti {
12477:     my ($cdom,$context) = @_;
12478:     my ($name,$cachename,%lti);
12479:     if ($context eq 'consumer') {
12480:         $name = 'ltitools';
12481:     } elsif ($context eq 'provider') {
12482:         $name = 'lti';
12483:     } elsif ($context eq 'linkprot') {
12484:         $name = 'ltisec';
12485:     } else {
12486:         return %lti;
12487:     }
12488: 
12489:     if ($context eq 'linkprot') {
12490:         $cachename = $context;
12491:     } else {
12492:         $cachename = $name;
12493:     }
12494:     
12495:     my ($result,$cached)=&is_cached_new($cachename,$cdom);
12496:     if (defined($cached)) {
12497:         if (ref($result) eq 'HASH') {
12498:             %lti = %{$result};
12499:         }
12500:     } else {
12501:         my %domconfig = &get_dom('configuration',[$name],$cdom);
12502:         if (ref($domconfig{$name}) eq 'HASH') {
12503:             if ($context eq 'linkprot') {
12504:                 if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
12505:                     %lti = %{$domconfig{$name}{'linkprot'}};
12506:                 }
12507:             } else {
12508:                 %lti = %{$domconfig{$name}};
12509:             }
12510:             if (($context eq 'consumer') && (keys(%lti))) {
12511:                 my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);
12512:                 if (ref($encdomconfig{$name}) eq 'HASH') {
12513:                     foreach my $id (keys(%lti)) {
12514:                         if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
12515:                             foreach my $item ('key','secret') {
12516:                                 $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
12517:                             }
12518:                         }
12519:                     }
12520:                 }
12521:             }
12522:         }
12523:         my $cachetime = 24*60*60;
12524:         &do_cache_new($cachename,$cdom,\%lti,$cachetime);
12525:     }
12526:     return %lti;
12527: }
12528: 
12529: sub get_course_lti {
12530:     my ($cnum,$cdom) = @_;
12531:     my $hashid=$cdom.'_'.$cnum;
12532:     my %courselti;
12533:     my ($result,$cached)=&is_cached_new('courselti',$hashid);
12534:     if (defined($cached)) {
12535:         if (ref($result) eq 'HASH') {
12536:             %courselti = %{$result};
12537:         }
12538:     } else {
12539:         %courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);
12540:         my $cachetime = 24*60*60;
12541:         &do_cache_new('courselti',$hashid,\%courselti,$cachetime);
12542:     }
12543:     return %courselti;
12544: }
12545: 
12546: sub courselti_itemid {
12547:     my ($cnum,$cdom,$url,$method,$params,$context) = @_;
12548:     my ($chome,$itemid);
12549:     $chome = &homeserver($cnum,$cdom);
12550:     return if ($chome eq 'no_host');
12551:     if (ref($params) eq 'HASH') {
12552:         my $rep;
12553:         if (grep { $_ eq $chome } current_machine_ids()) {
12554:             $rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
12555:         } else {
12556:             my $escurl = &escape($url);
12557:             my $escmethod = &escape($method);
12558:             my $items = &freeze_escape($params);
12559:             $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome);
12560:         }
12561:         unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
12562:                 ($rep eq 'unknown_cmd')) {
12563:             $itemid = $rep;
12564:         }
12565:     }
12566:     return $itemid;
12567: }
12568: 
12569: sub domainlti_itemid {
12570:     my ($cdom,$url,$method,$params,$context) = @_;
12571:     my ($primary_id,$itemid);
12572:     $primary_id = &domain($cdom,'primary');
12573:     return if ($primary_id eq '');
12574:     if (ref($params) eq 'HASH') {
12575:         my $rep;
12576:         if (grep { $_ eq $primary_id } current_machine_ids()) {
12577:             $rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
12578:         } else {
12579:             my $cnum = '';
12580:             my $escurl = &escape($url);
12581:             my $escmethod = &escape($method);
12582:             my $items = &freeze_escape($params);
12583:             $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id);
12584:         }
12585:         unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
12586:                 ($rep eq 'unknown_cmd')) {
12587:             $itemid = $rep;
12588:         }
12589:     }
12590:     return $itemid;
12591: }
12592: 
12593: sub count_supptools {
12594:     my ($cnum,$cdom,$ignorecache,$reload)=@_;
12595:     my $hashid=$cnum.':'.$cdom;
12596:     my ($numexttools,$cached);
12597:     unless ($ignorecache) {
12598:         ($numexttools,$cached) = &is_cached_new('supptools',$hashid);
12599:     }
12600:     unless (defined($cached)) {
12601:         my $chome=&homeserver($cnum,$cdom);
12602:         $numexttools = 0;
12603:         unless ($chome eq 'no_host') {
12604:             my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
12605:             if (ref($supplemental) eq 'HASH') {
12606:                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
12607:                     foreach my $key (keys(%{$supplemental->{'ids'}})) {
12608:                         if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
12609:                             $numexttools ++;
12610:                         }
12611:                     }
12612:                 }
12613:             }
12614:         }
12615:         &do_cache_new('supptools',$hashid,$numexttools,600);
12616:     }
12617:     return $numexttools;
12618: }
12619: 
12620: sub has_unhidden_suppfiles {
12621:     my ($cnum,$cdom,$ignorecache,$possdel)=@_;
12622:     my $hashid=$cnum.':'.$cdom;
12623:     my ($showsupp,$cached);
12624:     unless ($ignorecache) {
12625:         ($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
12626:     }
12627:     unless (defined($cached)) {
12628:         my $chome=&homeserver($cnum,$cdom);
12629:         unless ($chome eq 'no_host') {
12630:             my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
12631:             if (ref($supplemental) eq 'HASH') {
12632:                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
12633:                     foreach my $key (keys(%{$supplemental->{'ids'}})) {
12634:                         next if ($key =~ /\.sequence$/);
12635:                         if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {
12636:                             foreach my $id (@{$supplemental->{'ids'}->{$key}}) {
12637:                                 unless ($supplemental->{'hidden'}->{$id}) {
12638:                                     $showsupp = 1;
12639:                                     last;
12640:                                 }
12641:                             }
12642:                         }
12643:                         last if ($showsupp);
12644:                     }
12645:                 }
12646:             }
12647:         }
12648:         &do_cache_new('showsupp',$hashid,$showsupp,600);
12649:     }
12650:     return $showsupp;
12651: }
12652: 
12653: #
12654: # EXT resource caching routines
12655: #
12656: 
12657: {
12658: # Cache (5 seconds) of map hierarchy for speedup of navmaps display
12659: #
12660: # The course for which we cache
12661: my $cachedmapkey='';
12662: # The cached recursive maps for this course
12663: my %cachedmaps=();
12664: # When this was last done
12665: my $cachedmaptime='';
12666: 
12667: sub clear_EXT_cache_status {
12668:     &delenv('cache.EXT.');
12669: }
12670: 
12671: sub EXT_cache_status {
12672:     my ($target_domain,$target_user) = @_;
12673:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
12674:     if (exists($env{$cachename}) && ($env{$cachename}+600) > time) {
12675:         # We know already the user has no data
12676:         return 1;
12677:     } else {
12678:         return 0;
12679:     }
12680: }
12681: 
12682: sub EXT_cache_set {
12683:     my ($target_domain,$target_user) = @_;
12684:     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
12685:     #&appenv({$cachename => time});
12686: }
12687: 
12688: # --------------------------------------------------------- Value of a Variable
12689: sub EXT {
12690: 
12691:     my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
12692:     unless ($varname) { return ''; }
12693:     #get real user name/domain, courseid and symb
12694:     my $courseid;
12695:     my $publicuser;
12696:     if ($symbparm) {
12697: 	$symbparm=&get_symb_from_alias($symbparm);
12698:     }
12699:     if (!($uname && $udom)) {
12700:       (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
12701:       if (!$symbparm) {	$symbparm=$cursymb; }
12702:     } else {
12703: 	$courseid=$env{'request.course.id'};
12704:     }
12705:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
12706:     my $rest;
12707:     if (defined($therest[0])) {
12708:        $rest=join('.',@therest);
12709:     } else {
12710:        $rest='';
12711:     }
12712: 
12713:     my $qualifierrest=$qualifier;
12714:     if ($rest) { $qualifierrest.='.'.$rest; }
12715:     my $spacequalifierrest=$space;
12716:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
12717:     if ($realm eq 'user') {
12718: # --------------------------------------------------------------- user.resource
12719: 	if ($space eq 'resource') {
12720: 	    if ( (defined($Apache::lonhomework::parsing_a_problem)
12721: 		  || defined($Apache::lonhomework::parsing_a_task))
12722: 		 &&
12723: 		 ($symbparm eq &symbread()) ) {
12724: 		# if we are in the middle of processing the resource the
12725: 		# get the value we are planning on committing
12726:                 if (defined($Apache::lonhomework::results{$qualifierrest})) {
12727:                     return $Apache::lonhomework::results{$qualifierrest};
12728:                 } else {
12729:                     return $Apache::lonhomework::history{$qualifierrest};
12730:                 }
12731: 	    } else {
12732: 		my %restored;
12733: 		if ($publicuser || $env{'request.state'} eq 'construct') {
12734: 		    %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
12735: 		} else {
12736: 		    %restored=&restore($symbparm,$courseid,$udom,$uname);
12737: 		}
12738: 		return $restored{$qualifierrest};
12739: 	    }
12740: # ----------------------------------------------------------------- user.access
12741:         } elsif ($space eq 'access') {
12742: 	    # FIXME - not supporting calls for a specific user
12743:             return &allowed($qualifier,$rest);
12744: # ------------------------------------------ user.preferences, user.environment
12745:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
12746: 	    if (($uname eq $env{'user.name'}) &&
12747: 		($udom eq $env{'user.domain'})) {
12748: 		return $env{join('.',('environment',$qualifierrest))};
12749: 	    } else {
12750: 		my %returnhash;
12751: 		if (!$publicuser) {
12752: 		    %returnhash=&userenvironment($udom,$uname,
12753: 						 $qualifierrest);
12754: 		}
12755: 		return $returnhash{$qualifierrest};
12756: 	    }
12757: # ----------------------------------------------------------------- user.course
12758:         } elsif ($space eq 'course') {
12759: 	    # FIXME - not supporting calls for a specific user
12760:             return $env{join('.',('request.course',$qualifier))};
12761: # ------------------------------------------------------------------- user.role
12762:         } elsif ($space eq 'role') {
12763: 	    # FIXME - not supporting calls for a specific user
12764:             my ($role,$where)=split(/\./,$env{'request.role'});
12765:             if ($qualifier eq 'value') {
12766: 		return $role;
12767:             } elsif ($qualifier eq 'extent') {
12768:                 return $where;
12769:             }
12770: # ----------------------------------------------------------------- user.domain
12771:         } elsif ($space eq 'domain') {
12772:             return $udom;
12773: # ------------------------------------------------------------------- user.name
12774:         } elsif ($space eq 'name') {
12775:             return $uname;
12776: # ---------------------------------------------------- Any other user namespace
12777:         } else {
12778: 	    my %reply;
12779: 	    if (!$publicuser) {
12780: 		%reply=&get($space,[$qualifierrest],$udom,$uname);
12781: 	    }
12782: 	    return $reply{$qualifierrest};
12783:         }
12784:     } elsif ($realm eq 'query') {
12785: # ---------------------------------------------- pull stuff out of query string
12786:         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
12787: 						[$spacequalifierrest]);
12788: 	return $env{'form.'.$spacequalifierrest}; 
12789:    } elsif ($realm eq 'request') {
12790: # ------------------------------------------------------------- request.browser
12791:         if ($space eq 'browser') {
12792:             return $env{'browser.'.$qualifier};
12793: # ------------------------------------------------------------ request.filename
12794:         } else {
12795:             return $env{'request.'.$spacequalifierrest};
12796:         }
12797:     } elsif ($realm eq 'course') {
12798: # ---------------------------------------------------------- course.description
12799:         return $env{'course.'.$courseid.'.'.$spacequalifierrest};
12800:     } elsif ($realm eq 'resource') {
12801: 
12802: 	if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
12803: 	    if (!$symbparm) { $symbparm=&symbread(); }
12804: 	}
12805: 
12806:         if ($qualifier eq '') {
12807: 	    if ($space eq 'title') {
12808: 	        if (!$symbparm) { $symbparm = $env{'request.filename'}; }
12809: 	        return &gettitle($symbparm);
12810: 	    }
12811: 	
12812: 	    if ($space eq 'map') {
12813: 	        my ($map) = &decode_symb($symbparm);
12814: 	        return &symbread($map);
12815: 	    }
12816:             if ($space eq 'maptitle') {
12817:                 my ($map) = &decode_symb($symbparm);
12818:                 return &gettitle($map);
12819:             }
12820: 	    if ($space eq 'filename') {
12821: 	        if ($symbparm) {
12822: 		    return &clutter((&decode_symb($symbparm))[2]);
12823: 	        }
12824: 	        return &hreflocation('',$env{'request.filename'});
12825: 	    }
12826: 
12827:             if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {
12828:                 if ($space eq 'visibleparts') {
12829:                     my $navmap = Apache::lonnavmaps::navmap->new();
12830:                     my $item;
12831:                     if (ref($navmap)) {
12832:                         my $res = $navmap->getBySymb($symbparm);
12833:                         my $parts = $res->parts();
12834:                         if (ref($parts) eq 'ARRAY') {
12835:                             $item = join(',',@{$parts});
12836:                         }
12837:                         undef($navmap);
12838:                     }
12839:                     return $item;
12840:                 }
12841:             }
12842:         }
12843: 
12844: 	my ($section, $group, @groups, @recurseup, $recursed);
12845:         if (ref($recurseupref) eq 'ARRAY') {
12846:             @recurseup = @{$recurseupref};
12847:             $recursed = 1;
12848:         }
12849: 	my ($courselevelm,$courseleveli,$courselevel,$mapp);
12850:         if (($courseid eq '') && ($cid)) {
12851:             $courseid = $cid;
12852:         }
12853: 	if (($symbparm && $courseid) && 
12854: 	    (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid)))  {
12855: 
12856: 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
12857: 
12858: # ----------------------------------------------------- Cascading lookup scheme
12859: 	    my $symbp=$symbparm;
12860: 	    $mapp=&deversion((&decode_symb($symbp))[0]);
12861: 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
12862:             my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest;
12863: 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
12864: 	    if (($env{'user.name'} eq $uname) &&
12865: 		($env{'user.domain'} eq $udom)) {
12866: 		$section=$env{'request.course.sec'};
12867:                 @groups = split(/:/,$env{'request.course.groups'});  
12868:                 @groups=&sort_course_groups($courseid,@groups); 
12869: 	    } else {
12870: 		if (! defined($usection)) {
12871: 		    $section=&getsection($udom,$uname,$courseid);
12872: 		} else {
12873: 		    $section = $usection;
12874: 		}
12875:                 @groups = &get_users_groups($udom,$uname,$courseid);
12876: 	    }
12877: 
12878: 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
12879: 	    my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
12880:             my $secleveli=$courseid.'.['.$section.'].'.$recurseparm;
12881: 	    my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
12882: 
12883: 	    $courselevel=$courseid.'.'.$spacequalifierrest;
12884: 	    my $courselevelr=$courseid.'.'.$symbparm;
12885:             $courseleveli=$courseid.'.'.$recurseparm;
12886: 	    $courselevelm=$courseid.'.'.$mapparm;
12887: 
12888: # ----------------------------------------------------------- first, check user
12889: 
12890: 	    my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed,
12891:                                    \@recurseup,$courseid,'.',$spacequalifierrest, 
12892: 				       ([$courselevelr,'resource'],
12893: 					[$courselevelm,'map'     ],
12894:                                         [$courseleveli,'map'     ],
12895: 					[$courselevel, 'course'  ]));
12896: 	    if (defined($userreply)) { return &get_reply($userreply); }
12897: 
12898: # ------------------------------------------------ second, check some of course
12899:             my $coursereply;
12900:             if (@groups > 0) {
12901:                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
12902:                                        $recurseparm,$mapparm,$spacequalifierrest,
12903:                                        $mapp,\$recursed,\@recurseup);
12904:                 if (defined($coursereply)) { return &get_reply($coursereply); } 
12905:             }
12906: 
12907: 	    $coursereply=&resdata($env{'course.'.$courseid.'.num'},
12908: 				  $env{'course.'.$courseid.'.domain'},
12909: 				  'course',$mapp,\$recursed,\@recurseup,
12910:                                   $courseid,'.['.$section.'].',$spacequalifierrest,
12911: 				  ([$seclevelr,   'resource'],
12912: 				   [$seclevelm,   'map'     ],
12913:                                    [$secleveli,   'map'     ],
12914: 				   [$seclevel,    'course'  ],
12915: 				   [$courselevelr,'resource']));
12916: 	    if (defined($coursereply)) { return &get_reply($coursereply); }
12917: 
12918: # ------------------------------------------------------ third, check map parms
12919: 	    my %parmhash=();
12920: 	    my $thisparm='';
12921: 	    if (tie(%parmhash,'GDBM_File',
12922: 		    $env{'request.course.fn'}.'_parms.db',
12923: 		    &GDBM_READER(),0640)) {
12924: 		$thisparm=$parmhash{$symbparm};
12925: 		untie(%parmhash);
12926: 	    }
12927: 	    if ($thisparm) { return &get_reply([$thisparm,'resource']); }
12928: 	}
12929: # ------------------------------------------ fourth, look in resource metadata
12930:  
12931:         my $what = $spacequalifierrest;
12932: 	$what=~s/\./\_/;
12933: 	my $filename;
12934: 	if (!$symbparm) { $symbparm=&symbread(); }
12935: 	if ($symbparm) {
12936: 	    $filename=(&decode_symb($symbparm))[2];
12937: 	} else {
12938: 	    $filename=$env{'request.filename'};
12939: 	}
12940:         my $toolsymb;
12941:         if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) {
12942:             $toolsymb = $symbparm;
12943:         }
12944: 	my $metadata=&metadata($filename,$what,$toolsymb);
12945: 	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
12946: 	$metadata=&metadata($filename,'parameter_'.$what,$toolsymb);
12947: 	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
12948: 
12949: # ----------------------------------------------- fifth, look in rest of course
12950: 	if ($symbparm && defined($courseid) && 
12951: 	    $courseid eq $env{'request.course.id'}) {
12952: 	    my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
12953: 				     $env{'course.'.$courseid.'.domain'},
12954: 				     'course',$mapp,\$recursed,\@recurseup,
12955:                                      $courseid,'.',$spacequalifierrest,
12956: 				     ([$courselevelm,'map'   ],
12957:                                       [$courseleveli,'map'   ],
12958: 				      [$courselevel, 'course']));
12959: 	    if (defined($coursereply)) { return &get_reply($coursereply); }
12960: 	}
12961: # ------------------------------------------------------------------ Cascade up
12962: 	unless ($space eq '0') {
12963: 	    my @parts=split(/_/,$space);
12964: 	    my $id=pop(@parts);
12965: 	    my $part=join('_',@parts);
12966: 	    if ($part eq '') { $part='0'; }
12967: 	    my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
12968: 				 $symbparm,$udom,$uname,$section,1);
12969: 	    if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
12970: 	}
12971: 	if ($recurse) { return undef; }
12972: 	my $pack_def=&packages_tab_default($filename,$varname,$toolsymb);
12973: 	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
12974: # ---------------------------------------------------- Any other user namespace
12975:     } elsif ($realm eq 'environment') {
12976: # ----------------------------------------------------------------- environment
12977: 	if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
12978: 	    return $env{'environment.'.$spacequalifierrest};
12979: 	} else {
12980: 	    if ($uname eq 'anonymous' && $udom eq '') {
12981: 		return '';
12982: 	    }
12983: 	    my %returnhash=&userenvironment($udom,$uname,
12984: 					    $spacequalifierrest);
12985: 	    return $returnhash{$spacequalifierrest};
12986: 	}
12987:     } elsif ($realm eq 'system') {
12988: # ----------------------------------------------------------------- system.time
12989: 	if ($space eq 'time') {
12990: 	    return time;
12991:         }
12992:     } elsif ($realm eq 'server') {
12993: # ----------------------------------------------------------------- system.time
12994: 	if ($space eq 'name') {
12995: 	    return $ENV{'SERVER_NAME'};
12996:         }
12997:     } elsif ($realm eq 'client') {
12998:         if ($space eq 'remote_addr') {
12999:             return &get_requestor_ip();
13000:         }
13001:     }
13002:     return '';
13003: }
13004: 
13005: sub get_reply {
13006:     my ($reply_value) = @_;
13007:     if (ref($reply_value) eq 'ARRAY') {
13008:         if (wantarray) {
13009: 	    return @$reply_value;
13010:         }
13011:         return $reply_value->[0];
13012:     } else {
13013:         return $reply_value;
13014:     }
13015: }
13016: 
13017: sub check_group_parms {
13018:     my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp,
13019:         $recursed,$recurseupref) = @_;
13020:     my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'],
13021:                   [$what,'course']);
13022:     my $coursereply;
13023:     foreach my $group (@{$groups}) {
13024:         my @groupitems = ();
13025:         foreach my $level (@levels) {
13026:              my $item = $courseid.'.['.$group.'].'.$level->[0];
13027:              push(@groupitems,[$item,$level->[1]]);
13028:         }
13029:         my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
13030:                                    $env{'course.'.$courseid.'.domain'},
13031:                                    'course',$mapp,$recursed,$recurseupref,
13032:                                    $courseid,'.['.$group.'].',$what,
13033:                                    @groupitems);
13034:         last if (defined($coursereply));
13035:     }
13036:     return $coursereply;
13037: }
13038: 
13039: sub get_map_hierarchy {
13040:     my ($mapname,$courseid) = @_;
13041:     my @recurseup = ();
13042:     if ($mapname) {
13043:         if (($cachedmapkey eq $courseid) &&
13044:             (abs($cachedmaptime-time)<5)) {
13045:             if (ref($cachedmaps{$mapname}) eq 'ARRAY') {
13046:                 return @{$cachedmaps{$mapname}};
13047:             }
13048:         }
13049:         my $navmap = Apache::lonnavmaps::navmap->new();
13050:         if (ref($navmap)) {
13051:             @recurseup = $navmap->recurseup_maps($mapname);
13052:             undef($navmap);
13053:             $cachedmaps{$mapname} = \@recurseup;
13054:             $cachedmaptime=time;
13055:             $cachedmapkey=$courseid;
13056:         }
13057:     }
13058:     return @recurseup;
13059: }
13060: 
13061: }
13062: 
13063: sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
13064:     my ($courseid,@groups) = @_;
13065:     @groups = sort(@groups);
13066:     return @groups;
13067: }
13068: 
13069: sub packages_tab_default {
13070:     my ($uri,$varname,$toolsymb)=@_;
13071:     my (undef,$part,$name)=split(/\./,$varname);
13072: 
13073:     my (@extension,@specifics,$do_default);
13074:     foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) {
13075: 	my ($pack_type,$pack_part)=split(/_/,$package,2);
13076: 	if ($pack_type eq 'default') {
13077: 	    $do_default=1;
13078: 	} elsif ($pack_type eq 'extension') {
13079: 	    push(@extension,[$package,$pack_type,$pack_part]);
13080: 	} elsif ($pack_part eq $part || $pack_type eq 'part') {
13081: 	    # only look at packages defaults for packages that this id is
13082: 	    push(@specifics,[$package,$pack_type,$pack_part]);
13083: 	}
13084:     }
13085:     # first look for a package that matches the requested part id
13086:     foreach my $package (@specifics) {
13087: 	my (undef,$pack_type,$pack_part)=@{$package};
13088: 	next if ($pack_part ne $part);
13089: 	if (defined($packagetab{"$pack_type&$name&default"})) {
13090: 	    return $packagetab{"$pack_type&$name&default"};
13091: 	}
13092:     }
13093:     # look for any possible matching non extension_ package
13094:     foreach my $package (@specifics) {
13095: 	my (undef,$pack_type,$pack_part)=@{$package};
13096: 	if (defined($packagetab{"$pack_type&$name&default"})) {
13097: 	    return $packagetab{"$pack_type&$name&default"};
13098: 	}
13099: 	if ($pack_type eq 'part') { $pack_part='0'; }
13100: 	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
13101: 	    return $packagetab{$pack_type."_".$pack_part."&$name&default"};
13102: 	}
13103:     }
13104:     # look for any posible extension_ match
13105:     foreach my $package (@extension) {
13106: 	my ($package,$pack_type)=@{$package};
13107: 	if (defined($packagetab{"$pack_type&$name&default"})) {
13108: 	    return $packagetab{"$pack_type&$name&default"};
13109: 	}
13110: 	if (defined($packagetab{$package."&$name&default"})) {
13111: 	    return $packagetab{$package."&$name&default"};
13112: 	}
13113:     }
13114:     # look for a global default setting
13115:     if ($do_default && defined($packagetab{"default&$name&default"})) {
13116: 	return $packagetab{"default&$name&default"};
13117:     }
13118:     return undef;
13119: }
13120: 
13121: sub add_prefix_and_part {
13122:     my ($prefix,$part)=@_;
13123:     my $keyroot;
13124:     if (defined($prefix) && $prefix !~ /^__/) {
13125: 	# prefix that has a part already
13126: 	$keyroot=$prefix;
13127:     } elsif (defined($prefix)) {
13128: 	# prefix that is missing a part
13129: 	if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
13130:     } else {
13131: 	# no prefix at all
13132: 	if (defined($part)) { $keyroot='_'.$part; }
13133:     }
13134:     return $keyroot;
13135: }
13136: 
13137: # ---------------------------------------------------------------- Get metadata
13138: 
13139: my %metaentry;
13140: my %importedpartids;
13141: my %importedrespids;
13142: sub metadata {
13143:     my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
13144:     $uri=&declutter($uri);
13145:     # if it is a non metadata possible uri return quickly
13146:     if (($uri eq '') || 
13147: 	(($uri =~ m|^/*adm/|) && 
13148: 	     ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||
13149:         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
13150: 	return undef;
13151:     }
13152:     if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) 
13153: 	&& &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
13154: 	return undef;
13155:     }
13156:     my $filename=$uri;
13157:     $uri=~s/\.meta$//;
13158: #
13159: # Is the metadata already cached?
13160: # Look at timestamp of caching
13161: # Everything is cached by the main uri, libraries are never directly cached
13162: #
13163:     if (!defined($liburi)) {
13164: 	my ($result,$cached)=&is_cached_new('meta',$uri);
13165: 	if (defined($cached)) { return $result->{':'.$what}; }
13166:     }
13167: 
13168: #
13169: # If the uri is for an external tool the file from
13170: # which metadata should be retrieved depends on whether
13171: # the tool had been configured to be gradable (set in the Course
13172: # Editor or Resource Editor).
13173: #
13174: # If a valid symb has been included as the third arg in the call
13175: # to &metadata() that can be used to retrieve the value of
13176: # parameter_0_gradable set for the resource, and included in the
13177: # uploaded map containing the tool. The value is retrieved via
13178: # &EXT(), if a valid symb is available.  Otherwise the value of
13179: # gradable in the exttool_$marker.db file for the tool instance
13180: # is retrieved via &get().
13181: #
13182: # When lonuserstate::traceroute() calls lonnet::EXT() for 
13183: # hiddenresource and encrypturl (during course initialization)
13184: # the map-level parameter for resource.0.gradable included in the 
13185: # uploaded map containing the tool will not yet have been stored
13186: # in the user_course_parms.db file for the user's session, so in 
13187: # this case fall back to retrieving gradable status from the
13188: # exttool_$marker.db file.
13189: #
13190: # In order to avoid an infinite loop, &metadata() will return
13191: # before a call to &EXT(), if the uri is for an external tool
13192: # and the $what for which metadata is being requested is
13193: # parameter_0_gradable or 0_gradable.
13194: #
13195: 
13196:     if ($uri =~ /ext\.tool$/) {
13197:         if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) {
13198:             return;
13199:         } else {
13200:             my ($checked,$use_passback);
13201:             if ($toolsymb ne '') {
13202:                 (undef,undef,my $tooluri) = &decode_symb($toolsymb);
13203:                 if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) {
13204:                     $checked = 1;
13205:                     if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) {
13206:                         $use_passback = 1;
13207:                     }
13208:                 }
13209:             }
13210:             unless ($checked) {
13211:                 my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri);
13212:                 $marker=~s/\D//g;
13213:                 if ($marker) {
13214:                     my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum);
13215:                     $use_passback = $toolsettings{'gradable'};
13216:                 }
13217:             }
13218:             if ($use_passback) {
13219:                 $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool';
13220:             } else {
13221:                 $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool';
13222:             }
13223:         }
13224:     }
13225: 
13226:     {
13227: # Imported parts would go here
13228:         my @origfiletagids=();
13229:         my $importedparts=0;
13230: 
13231: # Imported responseids would go here
13232:         my $importedresponses=0;
13233: #
13234: # Is this a recursive call for a library?
13235: #
13236: #	if (! exists($metacache{$uri})) {
13237: #	    $metacache{$uri}={};
13238: #	}
13239: 	my $cachetime = 60*60;
13240:         if ($liburi) {
13241: 	    $liburi=&declutter($liburi);
13242:             $filename=$liburi;
13243:         } else {
13244: 	    &devalidate_cache_new('meta',$uri);
13245: 	    undef(%metaentry);
13246: 	}
13247:         my %metathesekeys=();
13248:         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
13249: 	my $metastring;
13250: 	if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) {
13251: 	    my $which = &hreflocation('','/'.($liburi || $uri));
13252: 	    $metastring = 
13253: 		&Apache::lonnet::ssi_body($which,
13254: 					  ('grade_target' => 'meta'));
13255: 	    $cachetime = 1; # only want this cached in the child not long term
13256: 	} elsif (($uri !~ m -^(editupload)/-) && 
13257:                  ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {
13258: 	    my $file=&filelocation('',&clutter($filename));
13259: 	    #push(@{$metaentry{$uri.'.file'}},$file);
13260: 	    $metastring=&getfile($file);
13261: 	}
13262:         my $parser=HTML::LCParser->new(\$metastring);
13263:         my $token;
13264:         undef %metathesekeys;
13265:         while ($token=$parser->get_token) {
13266: 	    if ($token->[0] eq 'S') {
13267: 		if (defined($token->[2]->{'package'})) {
13268: #
13269: # This is a package - get package info
13270: #
13271: 		    my $package=$token->[2]->{'package'};
13272: 		    my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
13273: 		    if (defined($token->[2]->{'id'})) { 
13274: 			$keyroot.='_'.$token->[2]->{'id'}; 
13275: 		    }
13276: 		    if ($metaentry{':packages'}) {
13277: 			$metaentry{':packages'}.=','.$package.$keyroot;
13278: 		    } else {
13279: 			$metaentry{':packages'}=$package.$keyroot;
13280: 		    }
13281: 		    foreach my $pack_entry (keys(%packagetab)) {
13282: 			my $part=$keyroot;
13283: 			$part=~s/^\_//;
13284: 			if ($pack_entry=~/^\Q$package\E\&/ || 
13285: 			    $pack_entry=~/^\Q$package\E_0\&/) {
13286: 			    my ($pack,$name,$subp)=split(/\&/,$pack_entry);
13287: 			    # ignore package.tab specified default values
13288:                             # here &package_tab_default() will fetch those
13289: 			    if ($subp eq 'default') { next; }
13290: 			    my $value=$packagetab{$pack_entry};
13291: 			    my $unikey;
13292: 			    if ($pack =~ /_0$/) {
13293: 				$unikey='parameter_0_'.$name;
13294: 				$part=0;
13295: 			    } else {
13296: 				$unikey='parameter'.$keyroot.'_'.$name;
13297: 			    }
13298: 			    if ($subp eq 'display') {
13299: 				$value.=' [Part: '.$part.']';
13300: 			    }
13301: 			    $metaentry{':'.$unikey.'.part'}=$part;
13302: 			    $metathesekeys{$unikey}=1;
13303: 			    unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
13304: 				$metaentry{':'.$unikey.'.'.$subp}=$value;
13305: 			    }
13306: 			    if (defined($metaentry{':'.$unikey.'.default'})) {
13307: 				$metaentry{':'.$unikey}=
13308: 				    $metaentry{':'.$unikey.'.default'};
13309: 			    }
13310: 			}
13311: 		    }
13312: 		} else {
13313: #
13314: # This is not a package - some other kind of start tag
13315: #
13316: 		    my $entry=$token->[1];
13317: 		    my $unikey='';
13318: 
13319: 		    if ($entry eq 'import') {
13320: #
13321: # Importing a library here
13322: #
13323:                         my $location=$parser->get_text('/import');
13324:                         my $dir=$filename;
13325:                         $dir=~s|[^/]*$||;
13326:                         $location=&filelocation($dir,$location);
13327: 
13328:                         my $importid=$token->[2]->{'id'};
13329:                         my $importmode=$token->[2]->{'importmode'};
13330: #
13331: # Check metadata for imported file to
13332: # see if it contained response items
13333: #
13334:                         my ($origfile,@libfilekeys);
13335:                         my %currmetaentry = %metaentry;
13336:                         @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
13337:                                                            $depthcount+1));
13338:                         if (grep(/^responseorder$/,@libfilekeys)) {
13339:                             my $libresponseorder = &metadata($location,'responseorder',undef,undef,
13340:                                                              undef,$depthcount+1);
13341:                             if ($libresponseorder ne '') {
13342:                                 if ($#origfiletagids<0) {
13343:                                     undef(%importedrespids);
13344:                                     undef(%importedpartids);
13345:                                 }
13346:                                 my @respids = split(/\s*,\s*/,$libresponseorder);
13347:                                 if (@respids) {
13348:                                     $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
13349:                                 }
13350:                                 if ($importedrespids{$importid} ne '') {
13351:                                     $importedresponses = 1;
13352: # We need to get the original file and the imported file to get the response order correct
13353: # Load and inspect original file
13354:                                     if ($#origfiletagids<0) {
13355:                                         my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
13356:                                         $origfile=&getfile($origfilelocation);
13357:                                         @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
13358:                                     }
13359:                                 }
13360:                             }
13361:                         }
13362: # Do not overwrite contents of %metaentry hash for resource itself with 
13363: # hash populated for imported library file
13364:                         %metaentry = %currmetaentry;
13365:                         undef(%currmetaentry);
13366:                         if ($importmode eq 'part') {
13367: # Import as part(s)
13368:                            $importedparts=1;
13369: # We need to get the original file and the imported file to get the part order correct
13370: # Good news: we do not need to worry about nested libraries, since parts cannot be nested
13371: # Load and inspect original file if we didn't do that already
13372:                            if ($#origfiletagids<0) {
13373:                                undef(%importedrespids);
13374:                                undef(%importedpartids);
13375:                                if ($origfile eq '') {
13376:                                    my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
13377:                                    $origfile=&getfile($origfilelocation);
13378:                                    @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
13379:                                }
13380:                            }
13381:                            my @impfilepartids;
13382: # If <partorder> tag is included in metadata for the imported file
13383: # get the parts in the imported file from that.
13384:                            if (grep(/^partorder$/,@libfilekeys)) {
13385:                                %currmetaentry = %metaentry;
13386:                                my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
13387:                                                             $depthcount+1);
13388:                                %metaentry = %currmetaentry;
13389:                                undef(%currmetaentry);
13390:                                if ($libpartorder ne '') {
13391:                                    @impfilepartids=split(/\s*,\s*/,$libpartorder);
13392:                                }
13393:                            } else {
13394: # If no <partorder> tag available, load and inspect imported file
13395:                                my $impfile=&getfile($location);
13396:                                @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
13397:                            }
13398:                            if ($#impfilepartids>=0) {
13399: # This problem had parts
13400:                                $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
13401:                            } else {
13402: # Importing by turning a single problem into a problem part
13403: # It gets the import-tags ID as part-ID
13404:                                $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
13405:                                $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
13406:                            }
13407:                         } else {
13408: # Import as problem or as normal import
13409:                             $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
13410:                             unless ($importmode eq 'problem') {
13411: # Normal import
13412:                                 if (defined($token->[2]->{'id'})) {
13413:                                     $unikey.='_'.$token->[2]->{'id'};
13414:                                 }
13415:                             }
13416: # Check metadata for imported file to
13417: # see if it contained parts
13418:                             if (grep(/^partorder$/,@libfilekeys)) {
13419:                                 %currmetaentry = %metaentry;
13420:                                 my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
13421:                                                              $depthcount+1);
13422:                                 %metaentry = %currmetaentry;
13423:                                 undef(%currmetaentry);
13424:                                 if ($libpartorder ne '') {
13425:                                     $importedparts = 1;
13426:                                     $importedpartids{$token->[2]->{'id'}}=$libpartorder;
13427:                                 }
13428:                             }
13429:                         }
13430: 			if ($depthcount<20) {
13431: 			    my $metadata = 
13432: 				&metadata($uri,'keys',$toolsymb,$location,$unikey,
13433: 					  $depthcount+1);
13434: 			    foreach my $meta (split(',',$metadata)) {
13435: 				$metaentry{':'.$meta}=$metaentry{':'.$meta};
13436: 				$metathesekeys{$meta}=1;
13437: 			    }
13438:                         }
13439: 		    } else {
13440: #
13441: # Not importing, some other kind of non-package, non-library start tag
13442: # 
13443:                         $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
13444:                         if (defined($token->[2]->{'id'})) {
13445:                             $unikey.='_'.$token->[2]->{'id'};
13446:                         }
13447: 			if (defined($token->[2]->{'name'})) { 
13448: 			    $unikey.='_'.$token->[2]->{'name'}; 
13449: 			}
13450: 			$metathesekeys{$unikey}=1;
13451: 			foreach my $param (@{$token->[3]}) {
13452: 			    $metaentry{':'.$unikey.'.'.$param} =
13453: 				$token->[2]->{$param};
13454: 			}
13455: 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
13456: 			my $default=$metaentry{':'.$unikey.'.default'};
13457: 			if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
13458: 		 # only ws inside the tag, and not in default, so use default
13459: 		 # as value
13460: 			    $metaentry{':'.$unikey}=$default;
13461: 			} elsif ( $internaltext =~ /\S/ ) {
13462: 		  # something interesting inside the tag
13463: 			    $metaentry{':'.$unikey}=$internaltext;
13464: 			} else {
13465: 		  # no interesting values, don't set a default
13466: 			}
13467: # end of not-a-package not-a-library import
13468: 		    }
13469: # end of not-a-package start tag
13470: 		}
13471: # the next is the end of "start tag"
13472: 	    }
13473: 	}
13474: 	my ($extension) = ($uri =~ /\.(\w+)$/);
13475: 	$extension = lc($extension);
13476: 	if ($extension eq 'htm') { $extension='html'; }
13477: 
13478: 	foreach my $key (keys(%packagetab)) {
13479: 	    #no specific packages #how's our extension
13480: 	    if ($key!~/^extension_\Q$extension\E&/) { next; }
13481: 	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
13482: 					 \%metathesekeys);
13483: 	}
13484: 
13485: 	if (!exists($metaentry{':packages'})
13486: 	    || $packagetab{"import_defaults&extension_$extension"}) {
13487: 	    foreach my $key (keys(%packagetab)) {
13488: 		#no specific packages well let's get default then
13489: 		if ($key!~/^default&/) { next; }
13490: 		&metadata_create_package_def($uri,$key,'default',
13491: 					     \%metathesekeys);
13492: 	    }
13493: 	}
13494: # are there custom rights to evaluate
13495: 	if ($metaentry{':copyright'} eq 'custom') {
13496: 
13497:     #
13498:     # Importing a rights file here
13499:     #
13500: 	    unless ($depthcount) {
13501: 		my $location=$metaentry{':customdistributionfile'};
13502: 		my $dir=$filename;
13503: 		$dir=~s|[^/]*$||;
13504: 		$location=&filelocation($dir,$location);
13505: 		my $rights_metadata =
13506: 		    &metadata($uri,'keys',$toolsymb,$location,'_rights',
13507: 			      $depthcount+1);
13508: 		foreach my $rights (split(',',$rights_metadata)) {
13509: 		    #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
13510: 		    $metathesekeys{$rights}=1;
13511: 		}
13512: 	    }
13513: 	}
13514: 	# uniqifiy package listing
13515: 	my %seen;
13516: 	my @uniq_packages =
13517: 	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
13518: 	$metaentry{':packages'} = join(',',@uniq_packages);
13519: 
13520:         if (($importedresponses) || ($importedparts)) {
13521:             if ($importedparts) {
13522: # We had imported parts and need to rebuild partorder
13523:                 $metaentry{':partorder'}='';
13524:                 $metathesekeys{'partorder'}=1;
13525:             }
13526:             if ($importedresponses) {
13527: # We had imported responses and need to rebuil responseorder
13528:                 $metaentry{':responseorder'}='';
13529:                 $metathesekeys{'responseorder'}=1;
13530:             }
13531:             for (my $index=0;$index<$#origfiletagids;$index+=2) {
13532:                 my $origid = $origfiletagids[$index+1];
13533:                 if ($origfiletagids[$index] eq 'part') {
13534: # Original part, part of the problem
13535:                     if ($importedparts) {
13536:                         $metaentry{':partorder'}.=','.$origid;
13537:                     }
13538:                 } elsif ($origfiletagids[$index] eq 'import') {
13539:                     if ($importedparts) {
13540: # We have imported parts at this position
13541:                         if ($importedpartids{$origid} ne '') {
13542:                             $metaentry{':partorder'}.=','.$importedpartids{$origid};
13543:                         }
13544:                     }
13545:                     if ($importedresponses) {
13546: # We have imported responses at this position
13547:                         if ($importedrespids{$origid} ne '') {
13548:                             $metaentry{':responseorder'}.=','.$importedrespids{$origid};
13549:                         }
13550:                     }
13551:                 } else {
13552: # Original response item, part of the problem
13553:                     if ($importedresponses) {
13554:                         $metaentry{':responseorder'}.=','.$origid;
13555:                     }
13556:                 }
13557:             }
13558:             if ($importedparts) {
13559:                 $metaentry{':partorder'}=~s/^\,//;
13560:             }
13561:             if ($importedresponses) {
13562:                 $metaentry{':responseorder'}=~s/^\,//;
13563:             }
13564:         }
13565: 	$metaentry{':keys'} = join(',',keys(%metathesekeys));
13566: 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
13567: 	$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
13568:         unless ($liburi) {
13569: 	    &do_cache_new('meta',$uri,\%metaentry,$cachetime);
13570:         }
13571: # this is the end of "was not already recently cached
13572:     }
13573:     return $metaentry{':'.$what};
13574: }
13575: 
13576: sub metadata_create_package_def {
13577:     my ($uri,$key,$package,$metathesekeys)=@_;
13578:     my ($pack,$name,$subp)=split(/\&/,$key);
13579:     if ($subp eq 'default') { next; }
13580:     
13581:     if (defined($metaentry{':packages'})) {
13582: 	$metaentry{':packages'}.=','.$package;
13583:     } else {
13584: 	$metaentry{':packages'}=$package;
13585:     }
13586:     my $value=$packagetab{$key};
13587:     my $unikey;
13588:     $unikey='parameter_0_'.$name;
13589:     $metaentry{':'.$unikey.'.part'}=0;
13590:     $$metathesekeys{$unikey}=1;
13591:     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
13592: 	$metaentry{':'.$unikey.'.'.$subp}=$value;
13593:     }
13594:     if (defined($metaentry{':'.$unikey.'.default'})) {
13595: 	$metaentry{':'.$unikey}=
13596: 	    $metaentry{':'.$unikey.'.default'};
13597:     }
13598: }
13599: 
13600: sub metadata_generate_part0 {
13601:     my ($metadata,$metacache,$uri) = @_;
13602:     my %allnames;
13603:     foreach my $metakey (keys(%$metadata)) {
13604: 	if ($metakey=~/^parameter\_(.*)/) {
13605: 	  my $part=$$metacache{':'.$metakey.'.part'};
13606: 	  my $name=$$metacache{':'.$metakey.'.name'};
13607: 	  if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
13608: 	    $allnames{$name}=$part;
13609: 	  }
13610: 	}
13611:     }
13612:     foreach my $name (keys(%allnames)) {
13613:       $$metadata{"parameter_0_$name"}=1;
13614:       my $key=":parameter_0_$name";
13615:       $$metacache{"$key.part"}='0';
13616:       $$metacache{"$key.name"}=$name;
13617:       $$metacache{"$key.type"}=$$metacache{':parameter_'.
13618: 					   $allnames{$name}.'_'.$name.
13619: 					   '.type'};
13620:       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
13621: 			     '.display'};
13622:       my $expr='[Part: '.$allnames{$name}.']';
13623:       $olddis=~s/\Q$expr\E/\[Part: 0\]/;
13624:       $$metacache{"$key.display"}=$olddis;
13625:     }
13626: }
13627: 
13628: # ------------------------------------------------------ Devalidate title cache
13629: 
13630: sub devalidate_title_cache {
13631:     my ($url)=@_;
13632:     if (!$env{'request.course.id'}) { return; }
13633:     my $symb=&symbread($url);
13634:     if (!$symb) { return; }
13635:     my $key=$env{'request.course.id'}."\0".$symb;
13636:     &devalidate_cache_new('title',$key);
13637: }
13638: 
13639: # ------------------------------------------------- Get the title of a course
13640: 
13641: sub current_course_title {
13642:     return $env{ 'course.' . $env{'request.course.id'} . '.description' };
13643: }
13644: # ------------------------------------------------- Get the title of a resource
13645: 
13646: sub gettitle {
13647:     my $urlsymb=shift;
13648:     my $symb=&symbread($urlsymb);
13649:     if ($symb) {
13650: 	my $key=$env{'request.course.id'}."\0".$symb;
13651: 	my ($result,$cached)=&is_cached_new('title',$key);
13652: 	if (defined($cached)) { 
13653: 	    return $result;
13654: 	}
13655: 	my ($map,$resid,$url)=&decode_symb($symb);
13656: 	my $title='';
13657: 	if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
13658: 	    $title = $env{'course.'.$env{'request.course.id'}.'.description'};
13659: 	} else {
13660: 	    if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
13661: 		    &GDBM_READER(),0640)) {
13662: 		my $mapid=$bighash{'map_pc_'.&clutter($map)};
13663: 		$title=$bighash{'title_'.$mapid.'.'.$resid};
13664: 		untie(%bighash);
13665: 	    }
13666: 	}
13667: 	$title=~s/\&colon\;/\:/gs;
13668: 	if ($title) {
13669: # Remember both $symb and $title for dynamic metadata
13670:             $accesshash{$symb.'___crstitle'}=$title;
13671:             $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
13672: # Cache this title and then return it
13673: 	    return &do_cache_new('title',$key,$title,600);
13674: 	}
13675: 	$urlsymb=$url;
13676:     }
13677:     my $title=&metadata($urlsymb,'title');
13678:     if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
13679:     return $title;
13680: }
13681: 
13682: sub get_slot {
13683:     my ($which,$cnum,$cdom)=@_;
13684:     if (!$cnum || !$cdom) {
13685: 	(undef,my $courseid)=&whichuser();
13686: 	$cdom=$env{'course.'.$courseid.'.domain'};
13687: 	$cnum=$env{'course.'.$courseid.'.num'};
13688:     }
13689:     my $key=join("\0",'slots',$cdom,$cnum,$which);
13690:     my %slotinfo;
13691:     if (exists($remembered{$key})) {
13692: 	$slotinfo{$which} = $remembered{$key};
13693:     } else {
13694: 	%slotinfo=&get('slots',[$which],$cdom,$cnum);
13695: 	&Apache::lonhomework::showhash(%slotinfo);
13696: 	my ($tmp)=keys(%slotinfo);
13697: 	if ($tmp=~/^error:/) { return (); }
13698: 	$remembered{$key} = $slotinfo{$which};
13699:     }
13700:     if (ref($slotinfo{$which}) eq 'HASH') {
13701: 	return %{$slotinfo{$which}};
13702:     }
13703:     return $slotinfo{$which};
13704: }
13705: 
13706: sub get_reservable_slots {
13707:     my ($cnum,$cdom,$uname,$udom) = @_;
13708:     my $now = time;
13709:     my $reservable_info;
13710:     my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom);
13711:     if (exists($remembered{$key})) {
13712:         $reservable_info = $remembered{$key};
13713:     } else {
13714:         my %resv;
13715:         ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) =
13716:         &Apache::loncommon::get_future_slots($cnum,$cdom,$now);
13717:         $reservable_info = \%resv;
13718:         $remembered{$key} = $reservable_info;
13719:     }
13720:     return $reservable_info;
13721: }
13722: 
13723: sub get_course_slots {
13724:     my ($cnum,$cdom) = @_;
13725:     my $hashid=$cnum.':'.$cdom;
13726:     my ($result,$cached) = &is_cached_new('allslots',$hashid);
13727:     if (defined($cached)) {
13728:         if (ref($result) eq 'HASH') {
13729:             return %{$result};
13730:         }
13731:     } else {
13732:         my %slots=&dump('slots',$cdom,$cnum);
13733:         my ($tmp) = keys(%slots);
13734:         if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
13735:             &do_cache_new('allslots',$hashid,\%slots,600);
13736:             return %slots;
13737:         }
13738:     }
13739:     return;
13740: }
13741: 
13742: sub devalidate_slots_cache {
13743:     my ($cnum,$cdom)=@_;
13744:     my $hashid=$cnum.':'.$cdom;
13745:     &devalidate_cache_new('allslots',$hashid);
13746: }
13747: 
13748: sub get_coursechange {
13749:     my ($cdom,$cnum) = @_;
13750:     if ($cdom eq '' || $cnum eq '') {
13751:         return unless ($env{'request.course.id'});
13752:         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
13753:         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
13754:     }
13755:     my $hashid=$cdom.'_'.$cnum;
13756:     my ($change,$cached)=&is_cached_new('crschange',$hashid);
13757:     if ((defined($cached)) && ($change ne '')) {
13758:         return $change;
13759:     } else {
13760:         my %crshash;
13761:         %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);
13762:         if ($crshash{'internal.contentchange'} eq '') {
13763:             $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
13764:             if ($change eq '') {
13765:                 %crshash = &get('environment',['internal.created'],$cdom,$cnum);
13766:                 $change = $crshash{'internal.created'};
13767:             }
13768:         } else {
13769:             $change = $crshash{'internal.contentchange'};
13770:         }
13771:         my $cachetime = 600;
13772:         &do_cache_new('crschange',$hashid,$change,$cachetime);
13773:     }
13774:     return $change;
13775: }
13776: 
13777: sub devalidate_coursechange_cache {
13778:     my ($cdom,$cnum)=@_;
13779:     my $hashid=$cdom.'_'.$cnum;
13780:     &devalidate_cache_new('crschange',$hashid);
13781: }
13782: 
13783: sub get_suppchange {
13784:     my ($cdom,$cnum) = @_;
13785:     if ($cdom eq '' || $cnum eq '') {
13786:         return unless ($env{'request.course.id'});
13787:         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
13788:         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
13789:     }
13790:     my $hashid=$cdom.'_'.$cnum;
13791:     my ($change,$cached)=&is_cached_new('suppchange',$hashid);
13792:     if ((defined($cached)) && ($change ne '')) {
13793:         return $change;
13794:     } else {
13795:         my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum);
13796:         if ($crshash{'internal.supplementalchange'} eq '') {
13797:             $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
13798:             if ($change eq '') {
13799:                 %crshash = &get('environment',['internal.created'],$cdom,$cnum);
13800:                 $change = $crshash{'internal.created'};
13801:             }
13802:         } else {
13803:             $change = $crshash{'internal.supplementalchange'};
13804:         }
13805:         my $cachetime = 600;
13806:         &do_cache_new('suppchange',$hashid,$change,$cachetime);
13807:     }
13808:     return $change;
13809: }
13810: 
13811: sub devalidate_suppchange_cache {
13812:     my ($cdom,$cnum)=@_;
13813:     my $hashid=$cdom.'_'.$cnum;
13814:     &devalidate_cache_new('suppchange',$hashid);
13815: }
13816: 
13817: sub update_supp_caches {
13818:     my ($cdom,$cnum) = @_;
13819:     my %servers = &internet_dom_servers($cdom);
13820:     my @ids=&current_machine_ids();
13821:     foreach my $server (keys(%servers)) {
13822:         next if (grep(/^\Q$server\E$/,@ids));
13823:         my $hashid=$cnum.':'.$cdom;
13824:         my $cachekey = &escape('showsupp').':'.&escape($hashid);
13825:         &remote_devalidate_cache($server,[$cachekey]);
13826:     }
13827:     &has_unhidden_suppfiles($cnum,$cdom,1,1);
13828:     &count_supptools($cnum,$cdom,1);
13829:     my $now = time;
13830:     if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
13831:         &Apache::lonnet::appenv({'request.course.suppupdated' => $now});
13832:     }
13833:     &put('environment',{'internal.supplementalchange' => $now},
13834:          $cdom,$cnum);
13835:     &Apache::lonnet::appenv(
13836:         {'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now});
13837:     &do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600);
13838: }
13839: 
13840: # ------------------------------------------------- Update symbolic store links
13841: 
13842: sub symblist {
13843:     my ($mapname,%newhash)=@_;
13844:     $mapname=&deversion(&declutter($mapname));
13845:     my %hash;
13846:     if (($env{'request.course.fn'}) && (%newhash)) {
13847:         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
13848:                       &GDBM_WRCREAT(),0640)) {
13849: 	    foreach my $url (keys(%newhash)) {
13850: 		next if ($url eq 'last_known'
13851: 			 && $env{'form.no_update_last_known'});
13852: 		$hash{declutter($url)}=&encode_symb($mapname,
13853: 						    $newhash{$url}->[1],
13854: 						    $newhash{$url}->[0]);
13855:             }
13856:             if (untie(%hash)) {
13857: 		return 'ok';
13858:             }
13859:         }
13860:     }
13861:     return 'error';
13862: }
13863: 
13864: # --------------------------------------------------------------- Verify a symb
13865: 
13866: sub symbverify {
13867:     my ($symb,$thisurl,$encstate)=@_;
13868:     my $thisfn=$thisurl;
13869:     $thisfn=&declutter($thisfn);
13870: # direct jump to resource in page or to a sequence - will construct own symbs
13871:     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
13872: # check URL part
13873:     my ($map,$resid,$url)=&decode_symb($symb);
13874: 
13875:     unless ($url eq $thisfn) { return 0; }
13876: 
13877:     $symb=&symbclean($symb);
13878:     $thisurl=&deversion($thisurl);
13879:     $thisfn=&deversion($thisfn);
13880: 
13881:     my %bighash;
13882:     my $okay=0;
13883: 
13884:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
13885:                             &GDBM_READER(),0640)) {
13886:         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
13887:             $thisurl =~ s/\?.+$//;
13888:             if ($map =~ m{^uploaded/.+\.page$}) {
13889:                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
13890:                 $thisurl =~ s{^\Qhttp://https://\E}{https://};
13891:             }
13892:         }
13893:         my $ids;
13894:         if ($map =~ m{^uploaded/.+\.page$}) {
13895:             $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
13896:         } else {
13897:             $ids=$bighash{'ids_'.&clutter($thisurl)};
13898:         }
13899:         unless ($ids) {
13900:             my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;  
13901:             $ids=$bighash{$idkey};
13902:         }
13903:         if ($ids) {
13904: # ------------------------------------------------------------------- Has ID(s)
13905:             if ($thisfn =~ m{^/adm/wrapper/ext/}) {
13906:                 $symb =~ s/\?.+$//;
13907:             }
13908: 	    foreach my $id (split(/\,/,$ids)) {
13909: 	       my ($mapid,$resid)=split(/\./,$id);
13910:                if (
13911:   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
13912:    eq $symb) {
13913:                    if (ref($encstate)) {
13914:                        $$encstate = $bighash{'encrypted_'.$id};
13915:                    }
13916: 		   if (($env{'request.role.adv'}) ||
13917: 		       ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
13918:                        ($thisurl eq '/adm/navmaps')) {
13919: 		       $okay=1;
13920:                        last;
13921: 		   }
13922: 	       }
13923: 	   }
13924:         }
13925: 	untie(%bighash);
13926:     }
13927:     return $okay;
13928: }
13929: 
13930: # --------------------------------------------------------------- Clean-up symb
13931: 
13932: sub symbclean {
13933:     my $symb=shift;
13934:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
13935: # remove version from map
13936:     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
13937: 
13938: # remove version from URL
13939:     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
13940: 
13941: # remove wrapper
13942: 
13943:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
13944:     $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
13945:     return $symb;
13946: }
13947: 
13948: # ---------------------------------------------- Split symb to find map and url
13949: 
13950: sub encode_symb {
13951:     my ($map,$resid,$url)=@_;
13952:     return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
13953: }
13954: 
13955: sub decode_symb {
13956:     my $symb=shift;
13957:     if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
13958:     my ($map,$resid,$url)=split(/___/,$symb);
13959:     return (&fixversion($map),$resid,&fixversion($url));
13960: }
13961: 
13962: sub fixversion {
13963:     my $fn=shift;
13964:     if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
13965:     my %bighash;
13966:     my $uri=&clutter($fn);
13967:     my $key=$env{'request.course.id'}.'_'.$uri;
13968: # is this cached?
13969:     my ($result,$cached)=&is_cached_new('courseresversion',$key);
13970:     if (defined($cached)) { return $result; }
13971: # unfortunately not cached, or expired
13972:     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
13973: 	    &GDBM_READER(),0640)) {
13974:  	if ($bighash{'version_'.$uri}) {
13975:  	    my $version=$bighash{'version_'.$uri};
13976:  	    unless (($version eq 'mostrecent') || 
13977: 		    ($version==&getversion($uri))) {
13978:  		$uri=~s/\.(\w+)$/\.$version\.$1/;
13979:  	    }
13980:  	}
13981:  	untie %bighash;
13982:     }
13983:     return &do_cache_new('courseresversion',$key,&declutter($uri),600);
13984: }
13985: 
13986: sub deversion {
13987:     my $url=shift;
13988:     $url=~s/\.\d+\.(\w+)$/\.$1/;
13989:     return $url;
13990: }
13991: 
13992: # ------------------------------------------------------ Return symb list entry
13993: 
13994: sub symbread {
13995:     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
13996:         $ignoresymbdb,$noenccheck)=@_;
13997:     my $cache_str='request.symbread.cached.'.$thisfn;
13998:     if (defined($env{$cache_str})) {
13999:         unless (ref($possibles) eq 'HASH') {
14000:             if ($ignorecachednull) {
14001:                 return $env{$cache_str} unless ($env{$cache_str} eq '');
14002:             } else {
14003:                 return $env{$cache_str};
14004:             }
14005:         }
14006:     }
14007: # no filename provided? try from environment
14008:     unless ($thisfn) {
14009:         if ($env{'request.symb'}) {
14010:             return $env{$cache_str}=&symbclean($env{'request.symb'});
14011: 	}
14012: 	$thisfn=$env{'request.filename'};
14013:     }
14014:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
14015: # is that filename actually a symb? Verify, clean, and return
14016:     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
14017: 	if (&symbverify($thisfn,$1)) {
14018: 	    return $env{$cache_str}=&symbclean($thisfn);
14019: 	}
14020:     }
14021:     $thisfn=declutter($thisfn);
14022:     my %hash;
14023:     my %bighash;
14024:     my $syval='';
14025:     if (($env{'request.course.fn'}) && ($thisfn)) {
14026:         unless ($ignoresymbdb) {
14027:             if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
14028:                           &GDBM_READER(),0640)) {
14029: 	        $syval=$hash{$thisfn};
14030:                 untie(%hash);
14031:             }
14032:             if ($syval && $checkforblock) {
14033:                 my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
14034:                 if (@blockers) {
14035:                     $syval='';
14036:                 }
14037:             }
14038:         }
14039: # ---------------------------------------------------------- There was an entry
14040:         if ($syval) {
14041: 	    #unless ($syval=~/\_\d+$/) {
14042: 		#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
14043: 		    #&appenv({'request.ambiguous' => $thisfn});
14044: 		    #return $env{$cache_str}='';
14045: 		#}    
14046: 		#$syval.=$1;
14047: 	    #}
14048:         } else {
14049: # ------------------------------------------------------- Was not in symb table
14050:            if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
14051:                             &GDBM_READER(),0640)) {
14052: # ---------------------------------------------- Get ID(s) for current resource
14053:               my $ids=$bighash{'ids_'.&clutter($thisfn)};
14054:               unless ($ids) { 
14055:                  $ids=$bighash{'ids_/'.$thisfn};
14056:               }
14057:               unless ($ids) {
14058: # alias?
14059: 		  $ids=$bighash{'mapalias_'.$thisfn};
14060:               }
14061:               if ($ids) {
14062: # ------------------------------------------------------------------- Has ID(s)
14063:                  my @possibilities=split(/\,/,$ids);
14064:                  if ($#possibilities==0) {
14065: # ----------------------------------------------- There is only one possibility
14066: 		     my ($mapid,$resid)=split(/\./,$ids);
14067: 		     $syval=&encode_symb($bighash{'map_id_'.$mapid},
14068: 						    $resid,$thisfn);
14069:                      if (ref($possibles) eq 'HASH') {
14070:                          unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
14071:                              $possibles->{$syval} = 1;
14072:                          }
14073:                      }
14074:                      if ($checkforblock) {
14075:                          unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
14076:                              my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck);
14077:                              if (@blockers) {
14078:                                  $syval = '';
14079:                                  untie(%bighash);
14080:                                  return $env{$cache_str}='';
14081:                              }
14082:                          }
14083:                      }
14084:                  } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { 
14085: # ------------------------------------------ There is more than one possibility
14086:                      my $realpossible=0;
14087:                      foreach my $id (@possibilities) {
14088: 			 my $file=$bighash{'src_'.$id};
14089:                          my $canaccess;
14090:                          if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
14091:                              $canaccess = 1;
14092:                          } else { 
14093:                              $canaccess = &allowed('bre',$file);
14094:                          }
14095:                          if ($canaccess) {
14096:          		     my ($mapid,$resid)=split(/\./,$id);
14097:                              if ($bighash{'map_type_'.$mapid} ne 'page') {
14098:                                  my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
14099: 						             $resid,$thisfn);
14100:                                  next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
14101:                                  next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
14102:                                  if ($checkforblock) {
14103:                                      my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck);
14104:                                      if (@blockers > 0) {
14105:                                          $syval = '';
14106:                                      } else {
14107:                                          $syval = $poss_syval;
14108:                                          $realpossible++;
14109:                                      }
14110:                                  } else {
14111:                                      $syval = $poss_syval;
14112:                                      $realpossible++;
14113:                                  }
14114:                                  if ($syval) {
14115:                                      if (ref($possibles) eq 'HASH') {
14116:                                          $possibles->{$syval} = 1;
14117:                                      }
14118:                                  }
14119:                              }
14120: 			 }
14121:                      }
14122: 		     if ($realpossible!=1) { $syval=''; }
14123:                  } else {
14124:                      $syval='';
14125:                  }
14126: 	      }
14127:               untie(%bighash);
14128:            }
14129:         }
14130:         if ($syval) {
14131: 	    return $env{$cache_str}=$syval;
14132:         }
14133:     }
14134:     &appenv({'request.ambiguous' => $thisfn});
14135:     return $env{$cache_str}='';
14136: }
14137: 
14138: # ---------------------------------------------------------- Return random seed
14139: 
14140: sub numval {
14141:     my $txt=shift;
14142:     $txt=~tr/A-J/0-9/;
14143:     $txt=~tr/a-j/0-9/;
14144:     $txt=~tr/K-T/0-9/;
14145:     $txt=~tr/k-t/0-9/;
14146:     $txt=~tr/U-Z/0-5/;
14147:     $txt=~tr/u-z/0-5/;
14148:     $txt=~s/\D//g;
14149:     if ($_64bit) { if ($txt > 2**32) { return -1; } }
14150:     return int($txt);
14151: }
14152: 
14153: sub numval2 {
14154:     my $txt=shift;
14155:     $txt=~tr/A-J/0-9/;
14156:     $txt=~tr/a-j/0-9/;
14157:     $txt=~tr/K-T/0-9/;
14158:     $txt=~tr/k-t/0-9/;
14159:     $txt=~tr/U-Z/0-5/;
14160:     $txt=~tr/u-z/0-5/;
14161:     $txt=~s/\D//g;
14162:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
14163:     my $total;
14164:     foreach my $val (@txts) { $total+=$val; }
14165:     if ($_64bit) { if ($total > 2**32) { return -1; } }
14166:     return int($total);
14167: }
14168: 
14169: sub numval3 {
14170:     use integer;
14171:     my $txt=shift;
14172:     $txt=~tr/A-J/0-9/;
14173:     $txt=~tr/a-j/0-9/;
14174:     $txt=~tr/K-T/0-9/;
14175:     $txt=~tr/k-t/0-9/;
14176:     $txt=~tr/U-Z/0-5/;
14177:     $txt=~tr/u-z/0-5/;
14178:     $txt=~s/\D//g;
14179:     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
14180:     my $total;
14181:     foreach my $val (@txts) { $total+=$val; }
14182:     if ($_64bit) { $total=(($total<<32)>>32); }
14183:     return $total;
14184: }
14185: 
14186: sub digest {
14187:     my ($data)=@_;
14188:     my $digest=&Digest::MD5::md5($data);
14189:     my ($a,$b,$c,$d)=unpack("iiii",$digest);
14190:     my ($e,$f);
14191:     {
14192:         use integer;
14193:         $e=($a+$b);
14194:         $f=($c+$d);
14195:         if ($_64bit) {
14196:             $e=(($e<<32)>>32);
14197:             $f=(($f<<32)>>32);
14198:         }
14199:     }
14200:     if (wantarray) {
14201: 	return ($e,$f);
14202:     } else {
14203: 	my $g;
14204: 	{
14205: 	    use integer;
14206: 	    $g=($e+$f);
14207: 	    if ($_64bit) {
14208: 		$g=(($g<<32)>>32);
14209: 	    }
14210: 	}
14211: 	return $g;
14212:     }
14213: }
14214: 
14215: sub latest_rnd_algorithm_id {
14216:     return '64bit5';
14217: }
14218: 
14219: sub get_rand_alg {
14220:     my ($courseid)=@_;
14221:     if (!$courseid) { $courseid=(&whichuser())[1]; }
14222:     if ($courseid) {
14223: 	return $env{"course.$courseid.rndseed"};
14224:     }
14225:     return &latest_rnd_algorithm_id();
14226: }
14227: 
14228: sub validCODE {
14229:     my ($CODE)=@_;
14230:     if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
14231:     return 0;
14232: }
14233: 
14234: sub getCODE {
14235:     if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; }
14236:     if ( (defined($Apache::lonhomework::parsing_a_problem) ||
14237: 	  defined($Apache::lonhomework::parsing_a_task) ) &&
14238: 	 &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
14239: 	return $Apache::lonhomework::history{'resource.CODE'};
14240:     }
14241:     return undef;
14242: }
14243: #
14244: #  Determines the random seed for a specific context:
14245: #
14246: # parameters:
14247: #   symb      - in course context the symb for the seed.
14248: #   course_id - The course id of the form domain_coursenum.
14249: #   domain    - Domain for the user.
14250: #   course    - Course for the user.
14251: #   cenv      - environment of the course.
14252: #
14253: # NOTE:
14254: #   All parameters are picked out of the environment if missing
14255: #   or not defined.
14256: #   If a symb cannot be determined the current time is used instead.
14257: #
14258: #  For a given well defined symb, courside, domain, username,
14259: #  and course environment, the seed is reproducible.
14260: #
14261: sub rndseed {
14262:     my ($symb,$courseid,$domain,$username, $cenv)=@_;
14263:     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
14264:     if (!defined($symb)) {
14265: 	unless ($symb=$wsymb) { return time; }
14266:     }
14267:     if (!defined $courseid) { 
14268: 	$courseid=$wcourseid; 
14269:     }
14270:     if (!defined $domain) { $domain=$wdomain; }
14271:     if (!defined $username) { $username=$wusername }
14272: 
14273:     my $which;
14274:     if (defined($cenv->{'rndseed'})) {
14275: 	$which = $cenv->{'rndseed'};
14276:     } else {
14277: 	$which =&get_rand_alg($courseid);
14278:     }
14279:     if (defined(&getCODE())) {
14280: 
14281: 	if ($which eq '64bit5') {
14282: 	    return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
14283: 	} elsif ($which eq '64bit4') {
14284: 	    return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
14285: 	} else {
14286: 	    return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
14287: 	}
14288:     } elsif ($which eq '64bit5') {
14289: 	return &rndseed_64bit5($symb,$courseid,$domain,$username);
14290:     } elsif ($which eq '64bit4') {
14291: 	return &rndseed_64bit4($symb,$courseid,$domain,$username);
14292:     } elsif ($which eq '64bit3') {
14293: 	return &rndseed_64bit3($symb,$courseid,$domain,$username);
14294:     } elsif ($which eq '64bit2') {
14295: 	return &rndseed_64bit2($symb,$courseid,$domain,$username);
14296:     } elsif ($which eq '64bit') {
14297: 	return &rndseed_64bit($symb,$courseid,$domain,$username);
14298:     }
14299:     return &rndseed_32bit($symb,$courseid,$domain,$username);
14300: }
14301: 
14302: sub rndseed_32bit {
14303:     my ($symb,$courseid,$domain,$username)=@_;
14304:     {
14305: 	use integer;
14306: 	my $symbchck=unpack("%32C*",$symb) << 27;
14307: 	my $symbseed=numval($symb) << 22;
14308: 	my $namechck=unpack("%32C*",$username) << 17;
14309: 	my $nameseed=numval($username) << 12;
14310: 	my $domainseed=unpack("%32C*",$domain) << 7;
14311: 	my $courseseed=unpack("%32C*",$courseid);
14312: 	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
14313: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
14314: 	#&logthis("rndseed :$num:$symb");
14315: 	if ($_64bit) { $num=(($num<<32)>>32); }
14316: 	return $num;
14317:     }
14318: }
14319: 
14320: sub rndseed_64bit {
14321:     my ($symb,$courseid,$domain,$username)=@_;
14322:     {
14323: 	use integer;
14324: 	my $symbchck=unpack("%32S*",$symb) << 21;
14325: 	my $symbseed=numval($symb) << 10;
14326: 	my $namechck=unpack("%32S*",$username);
14327: 	
14328: 	my $nameseed=numval($username) << 21;
14329: 	my $domainseed=unpack("%32S*",$domain) << 10;
14330: 	my $courseseed=unpack("%32S*",$courseid);
14331: 	
14332: 	my $num1=$symbchck+$symbseed+$namechck;
14333: 	my $num2=$nameseed+$domainseed+$courseseed;
14334: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
14335: 	#&logthis("rndseed :$num:$symb");
14336: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
14337: 	return "$num1,$num2";
14338:     }
14339: }
14340: 
14341: sub rndseed_64bit2 {
14342:     my ($symb,$courseid,$domain,$username)=@_;
14343:     {
14344: 	use integer;
14345: 	# strings need to be an even # of cahracters long, it it is odd the
14346:         # last characters gets thrown away
14347: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
14348: 	my $symbseed=numval($symb) << 10;
14349: 	my $namechck=unpack("%32S*",$username.' ');
14350: 	
14351: 	my $nameseed=numval($username) << 21;
14352: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
14353: 	my $courseseed=unpack("%32S*",$courseid.' ');
14354: 	
14355: 	my $num1=$symbchck+$symbseed+$namechck;
14356: 	my $num2=$nameseed+$domainseed+$courseseed;
14357: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
14358: 	#&logthis("rndseed :$num:$symb");
14359: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
14360: 	return "$num1,$num2";
14361:     }
14362: }
14363: 
14364: sub rndseed_64bit3 {
14365:     my ($symb,$courseid,$domain,$username)=@_;
14366:     {
14367: 	use integer;
14368: 	# strings need to be an even # of cahracters long, it it is odd the
14369:         # last characters gets thrown away
14370: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
14371: 	my $symbseed=numval2($symb) << 10;
14372: 	my $namechck=unpack("%32S*",$username.' ');
14373: 	
14374: 	my $nameseed=numval2($username) << 21;
14375: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
14376: 	my $courseseed=unpack("%32S*",$courseid.' ');
14377: 	
14378: 	my $num1=$symbchck+$symbseed+$namechck;
14379: 	my $num2=$nameseed+$domainseed+$courseseed;
14380: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
14381: 	#&logthis("rndseed :$num1:$num2:$_64bit");
14382: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
14383: 	
14384: 	return "$num1:$num2";
14385:     }
14386: }
14387: 
14388: sub rndseed_64bit4 {
14389:     my ($symb,$courseid,$domain,$username)=@_;
14390:     {
14391: 	use integer;
14392: 	# strings need to be an even # of cahracters long, it it is odd the
14393:         # last characters gets thrown away
14394: 	my $symbchck=unpack("%32S*",$symb.' ') << 21;
14395: 	my $symbseed=numval3($symb) << 10;
14396: 	my $namechck=unpack("%32S*",$username.' ');
14397: 	
14398: 	my $nameseed=numval3($username) << 21;
14399: 	my $domainseed=unpack("%32S*",$domain.' ') << 10;
14400: 	my $courseseed=unpack("%32S*",$courseid.' ');
14401: 	
14402: 	my $num1=$symbchck+$symbseed+$namechck;
14403: 	my $num2=$nameseed+$domainseed+$courseseed;
14404: 	#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
14405: 	#&logthis("rndseed :$num1:$num2:$_64bit");
14406: 	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
14407: 	
14408: 	return "$num1:$num2";
14409:     }
14410: }
14411: 
14412: sub rndseed_64bit5 {
14413:     my ($symb,$courseid,$domain,$username)=@_;
14414:     my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
14415:     return "$num1:$num2";
14416: }
14417: 
14418: sub rndseed_CODE_64bit {
14419:     my ($symb,$courseid,$domain,$username)=@_;
14420:     {
14421: 	use integer;
14422: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
14423: 	my $symbseed=numval2($symb);
14424: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
14425: 	my $CODEseed=numval(&getCODE());
14426: 	my $courseseed=unpack("%32S*",$courseid.' ');
14427: 	my $num1=$symbseed+$CODEchck;
14428: 	my $num2=$CODEseed+$courseseed+$symbchck;
14429: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
14430: 	#&logthis("rndseed :$num1:$num2:$symb");
14431: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
14432: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
14433: 	return "$num1:$num2";
14434:     }
14435: }
14436: 
14437: sub rndseed_CODE_64bit4 {
14438:     my ($symb,$courseid,$domain,$username)=@_;
14439:     {
14440: 	use integer;
14441: 	my $symbchck=unpack("%32S*",$symb.' ') << 16;
14442: 	my $symbseed=numval3($symb);
14443: 	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
14444: 	my $CODEseed=numval3(&getCODE());
14445: 	my $courseseed=unpack("%32S*",$courseid.' ');
14446: 	my $num1=$symbseed+$CODEchck;
14447: 	my $num2=$CODEseed+$courseseed+$symbchck;
14448: 	#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
14449: 	#&logthis("rndseed :$num1:$num2:$symb");
14450: 	if ($_64bit) { $num1=(($num1<<32)>>32); }
14451: 	if ($_64bit) { $num2=(($num2<<32)>>32); }
14452: 	return "$num1:$num2";
14453:     }
14454: }
14455: 
14456: sub rndseed_CODE_64bit5 {
14457:     my ($symb,$courseid,$domain,$username)=@_;
14458:     my $code = &getCODE();
14459:     my ($num1,$num2)=&digest("$symb,$courseid,$code");
14460:     return "$num1:$num2";
14461: }
14462: 
14463: sub setup_random_from_rndseed {
14464:     my ($rndseed)=@_;
14465:     if ($rndseed =~/([,:])/) {
14466:         my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
14467:         if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
14468:             &Math::Random::random_set_seed_from_phrase($rndseed);
14469:         } else {
14470:             &Math::Random::random_set_seed($num1,$num2);
14471:         }
14472:     } else {
14473: 	&Math::Random::random_set_seed_from_phrase($rndseed);
14474:     }
14475: }
14476: 
14477: sub latest_receipt_algorithm_id {
14478:     return 'receipt3';
14479: }
14480: 
14481: sub recunique {
14482:     my $fucourseid=shift;
14483:     my $unique;
14484:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
14485: 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
14486: 	$unique=$env{"course.$fucourseid.internal.encseed"};
14487:     } else {
14488: 	$unique=$perlvar{'lonReceipt'};
14489:     }
14490:     return unpack("%32C*",$unique);
14491: }
14492: 
14493: sub recprefix {
14494:     my $fucourseid=shift;
14495:     my $prefix;
14496:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'||
14497: 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
14498: 	$prefix=$env{"course.$fucourseid.internal.encpref"};
14499:     } else {
14500: 	$prefix=$perlvar{'lonHostID'};
14501:     }
14502:     return unpack("%32C*",$prefix);
14503: }
14504: 
14505: sub ireceipt {
14506:     my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
14507: 
14508:     my $return =&recprefix($fucourseid).'-';
14509: 
14510:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' ||
14511: 	$env{'request.state'} eq 'construct') {
14512: 	$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
14513: 	return $return;
14514:     }
14515: 
14516:     my $cuname=unpack("%32C*",$funame);
14517:     my $cudom=unpack("%32C*",$fudom);
14518:     my $cucourseid=unpack("%32C*",$fucourseid);
14519:     my $cusymb=unpack("%32C*",$fusymb);
14520:     my $cunique=&recunique($fucourseid);
14521:     my $cpart=unpack("%32S*",$part);
14522:     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
14523: 
14524: 	#&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
14525: 			       
14526: 	$return.= ($cunique%$cuname+
14527: 		   $cunique%$cudom+
14528: 		   $cusymb%$cuname+
14529: 		   $cusymb%$cudom+
14530: 		   $cucourseid%$cuname+
14531: 		   $cucourseid%$cudom+
14532: 		   $cpart%$cuname+
14533: 		   $cpart%$cudom);
14534:     } else {
14535: 	$return.= ($cunique%$cuname+
14536: 		   $cunique%$cudom+
14537: 		   $cusymb%$cuname+
14538: 		   $cusymb%$cudom+
14539: 		   $cucourseid%$cuname+
14540: 		   $cucourseid%$cudom);
14541:     }
14542:     return $return;
14543: }
14544: 
14545: sub receipt {
14546:     my ($part)=@_;
14547:     my ($symb,$courseid,$domain,$name) = &whichuser();
14548:     return &ireceipt($name,$domain,$courseid,$symb,$part);
14549: }
14550: 
14551: sub whichuser {
14552:     my ($passedsymb)=@_;
14553:     my ($symb,$courseid,$domain,$name,$publicuser);
14554:     if (defined($env{'form.grade_symb'})) {
14555: 	my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
14556: 	my $allowed=&allowed('vgr',$tmp_courseid);
14557: 	if (!$allowed &&
14558: 	    exists($env{'request.course.sec'}) &&
14559: 	    $env{'request.course.sec'} !~ /^\s*$/) {
14560: 	    $allowed=&allowed('vgr',$tmp_courseid.
14561: 			      '/'.$env{'request.course.sec'});
14562: 	}
14563: 	if ($allowed) {
14564: 	    ($symb)=&get_env_multiple('form.grade_symb');
14565: 	    $courseid=$tmp_courseid;
14566: 	    ($domain)=&get_env_multiple('form.grade_domain');
14567: 	    ($name)=&get_env_multiple('form.grade_username');
14568: 	    return ($symb,$courseid,$domain,$name,$publicuser);
14569: 	}
14570:     }
14571:     if (!$passedsymb) {
14572: 	$symb=&symbread();
14573:     } else {
14574: 	$symb=$passedsymb;
14575:     }
14576:     $courseid=$env{'request.course.id'};
14577:     $domain=$env{'user.domain'};
14578:     $name=$env{'user.name'};
14579:     if ($name eq 'public' && $domain eq 'public') {
14580: 	if (!defined($env{'form.username'})) {
14581: 	    $env{'form.username'}.=time.rand(10000000);
14582: 	}
14583: 	$name.=$env{'form.username'};
14584:     }
14585:     return ($symb,$courseid,$domain,$name,$publicuser);
14586: 
14587: }
14588: 
14589: # ------------------------------------------------------------ Serves up a file
14590: # returns either the contents of the file or 
14591: # -1 if the file doesn't exist
14592: #
14593: # if the target is a file that was uploaded via DOCS, 
14594: # a check will be made to see if a current copy exists on the local server,
14595: # if it does this will be served, otherwise a copy will be retrieved from
14596: # the home server for the course and stored in /home/httpd/html/userfiles on
14597: # the local server.   
14598: 
14599: sub getfile {
14600:     my ($file) = @_;
14601:     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
14602:     &repcopy($file);
14603:     return &readfile($file);
14604: }
14605: 
14606: sub repcopy_userfile {
14607:     my ($file)=@_;
14608:     my $londocroot = $perlvar{'lonDocRoot'};
14609:     if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
14610:     if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
14611:     my ($cdom,$cnum,$filename) = 
14612: 	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
14613:     my $uri="/uploaded/$cdom/$cnum/$filename";
14614:     if (-e "$file") {
14615: # we already have a local copy, check it out
14616: 	my @fileinfo = stat($file);
14617: 	my $rtncode;
14618: 	my $info;
14619: 	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
14620: 	if ($lwpresp ne 'ok') {
14621: # there is no such file anymore, even though we had a local copy
14622: 	    if ($rtncode eq '404') {
14623: 		unlink($file);
14624: 	    }
14625: 	    return -1;
14626: 	}
14627: 	if ($info < $fileinfo[9]) {
14628: # nice, the file we have is up-to-date, just say okay
14629: 	    return 'ok';
14630: 	} else {
14631: # the file is outdated, get rid of it
14632: 	    unlink($file);
14633: 	}
14634:     }
14635: # one way or the other, at this point, we don't have the file
14636: # construct the correct path for the file
14637:     my @parts = ($cdom,$cnum); 
14638:     if ($filename =~ m|^(.+)/[^/]+$|) {
14639: 	push @parts, split(/\//,$1);
14640:     }
14641:     my $path = $perlvar{'lonDocRoot'}.'/userfiles';
14642:     foreach my $part (@parts) {
14643: 	$path .= '/'.$part;
14644: 	if (!-e $path) {
14645: 	    mkdir($path,0770);
14646: 	}
14647:     }
14648: # now the path exists for sure
14649: # get a user agent
14650:     my $transferfile=$file.'.in.transfer';
14651: # FIXME: this should flock
14652:     if (-e $transferfile) { return 'ok'; }
14653:     my $request;
14654:     $uri=~s/^\///;
14655:     my $homeserver = &homeserver($cnum,$cdom);
14656:     my $hostname = &hostname($homeserver);
14657:     my $protocol = $protocol{$homeserver};
14658:     $protocol = 'http' if ($protocol ne 'https');
14659:     $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
14660:     my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);
14661: # did it work?
14662:     if ($response->is_error()) {
14663: 	unlink($transferfile);
14664: 	&logthis("Userfile repcopy failed for $uri");
14665: 	return -1;
14666:     }
14667: # worked, rename the transfer file
14668:     rename($transferfile,$file);
14669:     return 'ok';
14670: }
14671: 
14672: sub tokenwrapper {
14673:     my $uri=shift;
14674:     $uri=~s|^https?\://([^/]+)||;
14675:     $uri=~s|^/||;
14676:     $env{'user.environment'}=~/\/([^\/]+)\.id/;
14677:     my $token=$1;
14678:     my (undef,$udom,$uname,$file)=split('/',$uri,4);
14679:     if ($udom && $uname && $file) {
14680: 	$file=~s|(\?\.*)*$||;
14681:         &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
14682:         my $homeserver = &homeserver($uname,$udom);
14683:         my $hostname = &hostname($homeserver);
14684:         my $protocol = $protocol{$homeserver};
14685:         $protocol = 'http' if ($protocol ne 'https');
14686:         return $protocol.'://'.$hostname.'/'.$uri.
14687:                (($uri=~/\?/)?'&':'?').'token='.$token.
14688:                                '&tokenissued='.$perlvar{'lonHostID'};
14689:     } else {
14690:         return '/adm/notfound.html';
14691:     }
14692: }
14693: 
14694: # call with reqtype HEAD: get last modification time
14695: # call with reqtype GET: get the file contents
14696: # Do not call this with reqtype GET for large files! It loads everything into memory
14697: #
14698: sub getuploaded {
14699:     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
14700:     $uri=~s/^\///;
14701:     my $homeserver = &homeserver($cnum,$cdom);
14702:     my $hostname = &hostname($homeserver);
14703:     my $protocol = $protocol{$homeserver};
14704:     $protocol = 'http' if ($protocol ne 'https');
14705:     $uri = $protocol.'://'.$hostname.'/raw/'.$uri;
14706:     my $request=new HTTP::Request($reqtype,$uri);
14707:     my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
14708:     $$rtncode = $response->code;
14709:     if (! $response->is_success()) {
14710: 	return 'failed';
14711:     }      
14712:     if ($reqtype eq 'HEAD') {
14713: 	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
14714:     } elsif ($reqtype eq 'GET') {
14715: 	$$info = $response->content;
14716:     }
14717:     return 'ok';
14718: }
14719: 
14720: sub readfile {
14721:     my $file = shift;
14722:     if ( (! -e $file ) || ($file eq '') ) { return -1; };
14723:     my $fh;
14724:     open($fh,"<",$file);
14725:     my $a='';
14726:     while (my $line = <$fh>) { $a .= $line; }
14727:     return $a;
14728: }
14729: 
14730: sub filelocation {
14731:     my ($dir,$file) = @_;
14732:     my $location;
14733:     $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
14734: 
14735:     if ($file =~ m-^/adm/-) {
14736: 	$file=~s-^/adm/wrapper/-/-;
14737: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
14738:     }
14739: 
14740:     if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
14741:         $location = $file;
14742:     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
14743:         my ($udom,$uname,$filename)=
14744:   	    ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
14745:         my $home=&homeserver($uname,$udom);
14746:         my $is_me=0;
14747:         my @ids=&current_machine_ids();
14748:         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
14749:         if ($is_me) {
14750:   	    $location=propath($udom,$uname).'/userfiles/'.$filename;
14751:         } else {
14752:   	  $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
14753:   	      $udom.'/'.$uname.'/'.$filename;
14754:         }
14755:     } elsif ($file =~ m-^/adm/-) {
14756: 	$location = $perlvar{'lonDocRoot'}.'/'.$file;
14757:     } else {
14758:         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
14759:         $file=~s:^/(res|priv)/:/:;
14760:         my $space=$1;
14761:         if ( !( $file =~ m:^/:) ) {
14762:             $location = $dir. '/'.$file;
14763:         } else {
14764:             $location = $perlvar{'lonDocRoot'}.'/'.$space.$file;
14765:         }
14766:     }
14767:     $location=~s://+:/:g; # remove duplicate /
14768:     while ($location=~m{/\.\./}) {
14769: 	if ($location =~ m{/[^/]+/\.\./}) {
14770: 	    $location=~ s{/[^/]+/\.\./}{/}g;
14771: 	} else {
14772: 	    $location=~ s{/\.\./}{/}g;
14773: 	}
14774:     } #remove dir/..
14775:     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
14776:     return $location;
14777: }
14778: 
14779: sub hreflocation {
14780:     my ($dir,$file)=@_;
14781:     unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
14782: 	$file=filelocation($dir,$file);
14783:     } elsif ($file=~m-^/adm/-) {
14784: 	$file=~s-^/adm/wrapper/-/-;
14785: 	$file=~s-^/adm/coursedocs/showdoc/-/-;
14786:     }
14787:     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
14788: 	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
14789:     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
14790: 	$file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/}
14791: 	        {/uploaded/$1/$2/}x;
14792:     }
14793:     if ($file=~ m{^/userfiles/}) {
14794: 	$file =~ s{^/userfiles/}{/uploaded/};
14795:     }
14796:     return $file;
14797: }
14798: 
14799: 
14800: 
14801: 
14802: 
14803: sub current_machine_domains {
14804:     return &machine_domains(&hostname($perlvar{'lonHostID'}));
14805: }
14806: 
14807: sub machine_domains {
14808:     my ($hostname) = @_;
14809:     my @domains;
14810:     my %hostname = &all_hostnames();
14811:     while( my($id, $name) = each(%hostname)) {
14812: #	&logthis("-$id-$name-$hostname-");
14813: 	if ($hostname eq $name) {
14814: 	    push(@domains,&host_domain($id));
14815: 	}
14816:     }
14817:     return @domains;
14818: }
14819: 
14820: sub current_machine_ids {
14821:     return &machine_ids(&hostname($perlvar{'lonHostID'}));
14822: }
14823: 
14824: sub machine_ids {
14825:     my ($hostname) = @_;
14826:     $hostname ||= &hostname($perlvar{'lonHostID'});
14827:     my @ids;
14828:     my %name_to_host = &all_names();
14829:     if (ref($name_to_host{$hostname}) eq 'ARRAY') {
14830: 	return @{ $name_to_host{$hostname} };
14831:     }
14832:     return;
14833: }
14834: 
14835: sub additional_machine_domains {
14836:     my @domains;
14837:     if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
14838:         if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
14839:             while (my $line = <$fh>) {
14840:                 chomp($line);           
14841:                 $line =~ s/\s//g;
14842:                 push(@domains,$line);
14843:             }
14844:             close($fh);
14845:         }
14846:     }
14847:     return @domains;
14848: }
14849: 
14850: sub default_login_domain {
14851:     my $domain = $perlvar{'lonDefDomain'};
14852:     my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
14853:     foreach my $posdom (&current_machine_domains(),
14854:                         &additional_machine_domains()) {
14855:         if (lc($posdom) eq lc($testdomain)) {
14856:             $domain=$posdom;
14857:             last;
14858:         }
14859:     }
14860:     return $domain;
14861: }
14862: 
14863: sub shared_institution {
14864:     my ($dom,$lonhost) = @_;
14865:     if ($lonhost eq '') {
14866:         $lonhost = $perlvar{'lonHostID'};
14867:     }
14868:     my $same_intdom;
14869:     my $hostintdom = &internet_dom($lonhost);
14870:     if ($hostintdom ne '') {
14871:         my %iphost = &get_iphost();
14872:         my $primary_id = &domain($dom,'primary');
14873:         my $primary_ip = &get_host_ip($primary_id);
14874:         if (ref($iphost{$primary_ip}) eq 'ARRAY') {
14875:             foreach my $id (@{$iphost{$primary_ip}}) {
14876:                 my $intdom = &internet_dom($id);
14877:                 if ($intdom eq $hostintdom) {
14878:                     $same_intdom = 1;
14879:                     last;
14880:                 }
14881:             }
14882:         }
14883:     }
14884:     return $same_intdom;
14885: }
14886: 
14887: sub uses_sts {
14888:     my ($ignore_cache) = @_;
14889:     my $lonhost = $perlvar{'lonHostID'};
14890:     my $hostname = &hostname($lonhost);
14891:     my $sts_on;
14892:     if ($protocol{$lonhost} eq 'https') {
14893:         my $cachetime = 12*3600;
14894:         if (!$ignore_cache) {
14895:             ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
14896:             if (defined($cached)) {
14897:                 return $sts_on;
14898:             }
14899:         }
14900:         my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
14901:         my $request=new HTTP::Request('HEAD',$url);
14902:         my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
14903:         if ($response->is_success) {
14904:             my $has_sts = $response->header('Strict-Transport-Security');
14905:             if ($has_sts eq '') {
14906:                 $sts_on = 0;
14907:             } else {
14908:                 if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
14909:                     my $maxage = $1;
14910:                     if ($maxage) {
14911:                         $sts_on = 1;
14912:                     } else {
14913:                         $sts_on = 0;
14914:                     }
14915:                 } else {
14916:                     $sts_on = 0;
14917:                 }
14918:             }
14919:             return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
14920:         }
14921:     }
14922:     return;
14923: }
14924: 
14925: sub waf_allssl {
14926:     my ($host_name) = @_;
14927:     my $alias = &get_proxy_alias();
14928:     if ($host_name eq '') {
14929:         $host_name = $ENV{'SERVER_NAME'};
14930:     }
14931:     if (($host_name ne '') && ($alias eq $host_name)) {
14932:         my $serverhomedom = &host_domain($perlvar{'lonHostID'});
14933:         my %defdomdefaults = &get_domain_defaults($serverhomedom);
14934:         if ($defdomdefaults{'waf_sslopt'}) {
14935:             return $defdomdefaults{'waf_sslopt'};
14936:         }
14937:     }
14938:     return;
14939: }
14940: 
14941: sub get_requestor_ip {
14942:     my ($r,$nolookup,$noproxy) = @_;
14943:     my $from_ip;
14944:     if (ref($r)) {
14945:         if ($r->can('useragent_ip')) {
14946:             if ($noproxy && $r->can('client_ip')) {
14947:                 $from_ip = $r->client_ip();
14948:             } else {
14949:                 $from_ip = $r->useragent_ip();
14950:             }
14951:         } elsif ($r->connection->can('remote_ip')) {
14952:             $from_ip = $r->connection->remote_ip();
14953:         } else {
14954:             $from_ip = $r->get_remote_host($nolookup);
14955:         }
14956:     } else {
14957:         $from_ip = $ENV{'REMOTE_ADDR'};
14958:     }
14959:     return $from_ip if ($noproxy); 
14960:     # Who controls proxy settings for server
14961:     my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
14962:     my $proxyinfo = &get_proxy_settings($dom_in_use);
14963:     if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
14964:         if ($proxyinfo->{'vpnint'}) {
14965:             if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
14966:                 return $from_ip;
14967:             }
14968:         }
14969:         if ($proxyinfo->{'trusted'}) {
14970:             if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
14971:                 my $ipheader = $proxyinfo->{'ipheader'};
14972:                 my ($ip,$xfor);
14973:                 if (ref($r)) {
14974:                     if ($ipheader) {
14975:                         $ip = $r->headers_in->{$ipheader};
14976:                     }
14977:                     $xfor = $r->headers_in->{'X-Forwarded-For'};
14978:                 } else {
14979:                     if ($ipheader) {
14980:                         $ip = $ENV{'HTTP_'.uc($ipheader)};
14981:                     }
14982:                     $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
14983:                 }
14984:                 if (($ip eq '') && ($xfor ne '')) {
14985:                     foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
14986:                         unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
14987:                             $ip = $poss_ip;
14988:                             last;
14989:                         }
14990:                     }
14991:                 }
14992:                 if ($ip ne '') {
14993:                     return $ip;
14994:                 }
14995:             }
14996:         }
14997:     }
14998:     return $from_ip;
14999: }
15000: 
15001: sub get_proxy_settings {
15002:     my ($dom_in_use) = @_;
15003:     my %domdefaults = &get_domain_defaults($dom_in_use);
15004:     my $proxyinfo = {
15005:                        ipheader => $domdefaults{'waf_ipheader'},
15006:                        trusted  => $domdefaults{'waf_trusted'},
15007:                        vpnint   => $domdefaults{'waf_vpnint'},
15008:                        vpnext   => $domdefaults{'waf_vpnext'},
15009:                        sslopt   => $domdefaults{'waf_sslopt'},
15010:                     };
15011:     return $proxyinfo;
15012: }
15013: 
15014: sub ip_match {
15015:     my ($ip,$pattern_str) = @_;
15016:     $ip=Net::CIDR::cidrvalidate($ip);
15017:     if ($ip) {
15018:         return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
15019:     }
15020:     return;
15021: }
15022: 
15023: sub get_proxy_alias {
15024:     my ($lonid) = @_;
15025:     if ($lonid eq '') {
15026:         $lonid = $perlvar{'lonHostID'};
15027:     }
15028:     if (!defined(&hostname($lonid))) {
15029:         return;
15030:     }
15031:     if ($lonid ne '') {
15032:         my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
15033:         if ($cached) {
15034:             return $alias;
15035:         }
15036:         my $dom = &host_domain($lonid);
15037:         if ($dom ne '') {
15038:             my $cachetime = 60*60*24;
15039:             my %domconfig =
15040:                 &get_dom('configuration',['wafproxy'],$dom);
15041:             if (ref($domconfig{'wafproxy'}) eq 'HASH') {
15042:                 if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
15043:                     $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
15044:                 }
15045:             }
15046:             return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
15047:         }
15048:     }
15049:     return;
15050: }
15051: 
15052: sub use_proxy_alias {
15053:     my ($r,$lonid) = @_;
15054:     my $alias = &get_proxy_alias($lonid);
15055:     if ($alias) {
15056:         my $dom = &host_domain($lonid);
15057:         if ($dom ne '') {
15058:             my $proxyinfo = &get_proxy_settings($dom);
15059:             my ($vpnint,$remote_ip);
15060:             if (ref($proxyinfo) eq 'HASH') {
15061:                 $vpnint = $proxyinfo->{'vpnint'};
15062:                 if ($vpnint) {
15063:                     $remote_ip = &get_requestor_ip($r,1,1);
15064:                 }
15065:             }
15066:             unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
15067:                 return $alias;
15068:             }
15069:         }
15070:     }
15071:     return;
15072: }
15073: 
15074: sub alias_sso {
15075:     my ($lonid) = @_;
15076:     if ($lonid eq '') {
15077:         $lonid = $perlvar{'lonHostID'};
15078:     }
15079:     if (!defined(&hostname($lonid))) {
15080:         return;
15081:     }
15082:     if ($lonid ne '') {
15083:         my ($use_alias,$cached) = &is_cached_new('proxysaml',$lonid);
15084:         if ($cached) {
15085:             return $use_alias;
15086:         }
15087:         my $dom = &host_domain($lonid);
15088:         if ($dom ne '') {
15089:             my $cachetime = 60*60*24;
15090:             my %domconfig =
15091:                 &get_dom('configuration',['wafproxy'],$dom);
15092:             if (ref($domconfig{'wafproxy'}) eq 'HASH') {
15093:                 if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
15094:                     $use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
15095:                 }
15096:             }
15097:             return &do_cache_new('proxysaml',$lonid,$use_alias,$cachetime);
15098:         }
15099:     }
15100:     return;
15101: }
15102: 
15103: sub get_saml_landing {
15104:     my ($lonid) = @_;
15105:     if ($lonid eq '') {
15106:         my $defdom = &default_login_domain();
15107:         my @hosts = &current_machine_ids();
15108:         if (@hosts > 1) {
15109:             foreach my $hostid (@hosts) {
15110:                 if (&host_domain($hostid) eq $defdom) {
15111:                     $lonid = $hostid;
15112:                     last;
15113:                 }
15114:             }
15115:         } else {
15116:             $lonid = $perlvar{'lonHostID'};
15117:         }
15118:         if ($lonid) {
15119:             unless (&host_domain($lonid) eq $defdom) {
15120:                 return;
15121:             }
15122:         } else {
15123:             return;
15124:         }
15125:     } elsif (!defined(&hostname($lonid))) {
15126:         return;
15127:     }
15128:     my ($landing,$cached) = &is_cached_new('samllanding',$lonid);
15129:     if ($cached) {
15130:         return $landing;
15131:     }
15132:     my $dom = &host_domain($lonid);
15133:     if ($dom ne '') {
15134:         my $cachetime = 60*60*24;
15135:         my %domconfig =
15136:             &get_dom('configuration',['login'],$dom);
15137:         if (ref($domconfig{'login'}) eq 'HASH') {
15138:             if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
15139:                 if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
15140:                     $landing = 1;
15141:                 }
15142:             }
15143:         }
15144:         return &do_cache_new('samllanding',$lonid,$landing,$cachetime);
15145:     }
15146:     return;
15147: }
15148: 
15149: # ------------------------------------------------------------- Declutters URLs
15150: 
15151: sub declutter {
15152:     my $thisfn=shift;
15153:     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
15154:     unless ($thisfn=~m{^/home/httpd/html/priv/}) {
15155:         $thisfn=~s{^/home/httpd/html}{};
15156:     }
15157:     $thisfn=~s/^\///;
15158:     $thisfn=~s|^adm/wrapper/||;
15159:     $thisfn=~s|^adm/coursedocs/showdoc/||;
15160:     $thisfn=~s/^res\///;
15161:     $thisfn=~s/^priv\///;
15162:     unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
15163:         $thisfn=~s/\?.+$//;
15164:     }
15165:     return $thisfn;
15166: }
15167: 
15168: # ------------------------------------------------------------- Clutter up URLs
15169: 
15170: sub clutter {
15171:     my $thisfn='/'.&declutter(shift);
15172:     if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/}
15173: 	|| $thisfn =~ m{^/adm/(includes|pages)} ) { 
15174:        $thisfn='/res'.$thisfn; 
15175:     }
15176:     if ($thisfn !~m|^/adm|) {
15177: 	if ($thisfn =~ m|^/ext/|) {
15178: 	    $thisfn='/adm/wrapper'.$thisfn;
15179: 	} else {
15180: 	    my ($ext) = ($thisfn =~ /\.(\w+)$/);
15181: 	    my $embstyle=&Apache::loncommon::fileembstyle($ext);
15182: 	    if ($embstyle eq 'ssi'
15183: 		|| ($embstyle eq 'hdn')
15184: 		|| ($embstyle eq 'rat')
15185: 		|| ($embstyle eq 'prv')
15186: 		|| ($embstyle eq 'ign')) {
15187: 		#do nothing with these
15188: 	    } elsif (($embstyle eq 'img') 
15189: 		|| ($embstyle eq 'emb')
15190: 		|| ($embstyle eq 'wrp')) {
15191: 		$thisfn='/adm/wrapper'.$thisfn;
15192: 	    } elsif ($embstyle eq 'unk'
15193: 		     && $thisfn!~/\.(sequence|page)$/) {
15194: 		$thisfn='/adm/coursedocs/showdoc'.$thisfn;
15195: 	    } else {
15196: #		&logthis("Got a blank emb style");
15197: 	    }
15198: 	}
15199:     } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
15200:         $thisfn='/adm/wrapper'.$thisfn;
15201:     }
15202:     return $thisfn;
15203: }
15204: 
15205: sub clutter_with_no_wrapper {
15206:     my $uri = &clutter(shift);
15207:     if ($uri =~ m-^/adm/-) {
15208: 	$uri =~ s-^/adm/wrapper/-/-;
15209: 	$uri =~ s-^/adm/coursedocs/showdoc/-/-;
15210:     }
15211:     return $uri;
15212: }
15213: 
15214: sub freeze_escape {
15215:     my ($value)=@_;
15216:     if (ref($value)) {
15217: 	$value=&nfreeze($value);
15218: 	return '__FROZEN__'.&escape($value);
15219:     }
15220:     return &escape($value);
15221: }
15222: 
15223: 
15224: sub thaw_unescape {
15225:     my ($value)=@_;
15226:     if ($value =~ /^__FROZEN__/) {
15227: 	substr($value,0,10,undef);
15228: 	$value=&unescape($value);
15229: 	return &thaw($value);
15230:     }
15231:     return &unescape($value);
15232: }
15233: 
15234: sub correct_line_ends {
15235:     my ($result)=@_;
15236:     $$result =~s/\r\n/\n/mg;
15237:     $$result =~s/\r/\n/mg;
15238: }
15239: # ================================================================ Main Program
15240: 
15241: sub goodbye {
15242:    &logthis("Starting Shut down");
15243: #not converted to using infrastruture and probably shouldn't be
15244:    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
15245: #converted
15246: #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
15247:    &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
15248: #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
15249: #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
15250: #1.1 only
15251: #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
15252: #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
15253: #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
15254: #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
15255:    &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
15256:    &logthis(sprintf("%-20s is %s",'kicks',$kicks));
15257:    &logthis(sprintf("%-20s is %s",'hits',$hits));
15258:    &flushcourselogs();
15259:    &logthis("Shutting down");
15260: }
15261: 
15262: sub get_dns {
15263:     my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
15264:     if (!$ignore_cache) {
15265: 	my ($content,$cached)=
15266: 	    &is_cached_new('dns',$url);
15267: 	if ($cached) {
15268: 	    &$func($content,$hashref);
15269: 	    return;
15270: 	}
15271:     }
15272: 
15273:     my %alldns;
15274:     if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
15275:         foreach my $dns (<$config>) {
15276: 	    next if ($dns !~ /^\^(\S*)/x);
15277:             my $line = $1;
15278:             my ($host,$protocol) = split(/:/,$line);
15279:             if ($protocol ne 'https') {
15280:                 $protocol = 'http';
15281:             }
15282: 	    $alldns{$host} = $protocol;
15283:         }
15284:         close($config);
15285:     }
15286:     while (%alldns) {
15287: 	my ($dns) = sort { $b cmp $a } keys(%alldns);
15288:         my ($contents,@content);
15289:         if ($dns eq Sys::Hostname::FQDN::fqdn()) {
15290:             my $command = (split('/',$url))[3];
15291:             my ($dir,$file) = &parse_getdns_url($command,$url);
15292:             delete($alldns{$dns});
15293:             next if (($dir eq '') || ($file eq ''));
15294:             if (open(my $config,'<',"$dir/$file")) {
15295:                 @content = <$config>;
15296:                 close($config);
15297:             }
15298:             if ($url eq '/adm/dns/loncapaCRL') {
15299:                 $contents = join('',@content);
15300:             }
15301:         } else {
15302: 	    my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
15303:             my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
15304:             delete($alldns{$dns});
15305: 	    next if ($response->is_error());
15306:             if ($url eq '/adm/dns/loncapaCRL') {
15307:                 $contents = $response->content;
15308:             } else {
15309:                 @content = split("\n",$response->content);
15310:             }
15311:         }
15312:         if ($url eq '/adm/dns/loncapaCRL') {
15313:             return &$func($contents);
15314:         } else {
15315: 	    unless ($nocache) {
15316: 	        &do_cache_new('dns',$url,\@content,30*24*60*60);
15317: 	    }
15318: 	    &$func(\@content,$hashref);
15319:             return;
15320:         }
15321:     }
15322:     my $which = (split('/',$url,4))[3];
15323:     if ($which eq 'loncapaCRL') {
15324:         my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
15325:         if (-e $diskfile) {
15326:             &logthis("unable to contact DNS, on disk file $diskfile not updated");
15327:         } else {
15328:             &logthis("unable to contact DNS, no on disk file $diskfile available");
15329:         }
15330:     } else {
15331:         &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
15332:         if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
15333:             my @content = <$config>;
15334:             close($config);
15335:             &$func(\@content,$hashref);
15336:         }
15337:     }
15338:     return;
15339: }
15340: 
15341: # ------------------------------------------------------Get DNS checksums file
15342: sub parse_dns_checksums_tab {
15343:     my ($lines,$hashref) = @_;
15344:     my $lonhost = $perlvar{'lonHostID'};
15345:     my $machine_dom = &host_domain($lonhost);
15346:     my $loncaparev = &get_server_loncaparev($machine_dom);
15347:     my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
15348:     my $webconfdir = '/etc/httpd/conf';
15349:     if ($distro =~ /^(ubuntu|debian)(\d+)$/) {
15350:         $webconfdir = '/etc/apache2';
15351:     } elsif ($distro =~ /^sles(\d+)$/) {
15352:         if ($1 >= 10) {
15353:             $webconfdir = '/etc/apache2';
15354:         }
15355:     } elsif ($distro =~ /^suse(\d+\.\d+)$/) {
15356:         if ($1 >= 10.0) {
15357:             $webconfdir = '/etc/apache2';
15358:         }
15359:     }
15360:     my ($release,$timestamp) = split(/\-/,$loncaparev);
15361:     my (%chksum,%revnum);
15362:     if (ref($lines) eq 'ARRAY') {
15363:         chomp(@{$lines});
15364:         my $version = shift(@{$lines});
15365:         if ($version eq $release) {  
15366:             foreach my $line (@{$lines}) {
15367:                 my ($file,$version,$shasum) = split(/,/,$line);
15368:                 if ($file =~ m{^/etc/httpd/conf}) {
15369:                     if ($webconfdir eq '/etc/apache2') {
15370:                         $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/};
15371:                     }
15372:                 }
15373:                 $chksum{$file} = $shasum;
15374:                 $revnum{$file} = $version;
15375:             }
15376:             if (ref($hashref) eq 'HASH') {
15377:                 %{$hashref} = (
15378:                                 sums     => \%chksum,
15379:                                 versions => \%revnum,
15380:                               );
15381:             }
15382:         }
15383:     }
15384:     return;
15385: }
15386: 
15387: sub fetch_dns_checksums {
15388:     my %checksums;
15389:     my $machine_dom = &host_domain($perlvar{'lonHostID'});
15390:     my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
15391:     my ($release,$timestamp) = split(/\-/,$loncaparev);
15392:     &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
15393:              \%checksums);
15394:     return \%checksums;
15395: }
15396: 
15397: sub fetch_crl_pemfile {
15398:     return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1);
15399: }
15400: 
15401: sub save_crl_pem {
15402:     my ($content) = @_;
15403:     my ($msg,$hadchanges);
15404:     if ($content ne '') {
15405:         my $now = time;
15406:         my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
15407:         my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
15408:         if (open(my $fh,'>',"$tmpcrl")) {
15409:             print $fh $content;
15410:             close($fh);
15411:             if (-e $lonca) {
15412:                 if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
15413:                     my $check = <PIPE>;
15414:                     close(PIPE);
15415:                     chomp($check);
15416:                     if ($check eq 'verify OK') {
15417:                         my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
15418:                         my $backup;
15419:                         if (-e $dest) {
15420:                             if (&File::Copy::move($dest,"$dest.bak")) {
15421:                                 $backup = 'ok';
15422:                             }
15423:                         }
15424:                         if (&File::Copy::move($tmpcrl,$dest)) {
15425:                             $msg = 'ok';
15426:                             if ($backup) {
15427:                                 my (%oldnums,%newnums);
15428:                                 if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) {
15429:                                     while (<PIPE>) {
15430:                                         $oldnums{(split(/:/))[1]} = 1;
15431:                                     }
15432:                                     close(PIPE);
15433:                                 }
15434:                                 if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) {
15435:                                     while(<PIPE>) {
15436:                                         $newnums{(split(/:/))[1]} = 1;
15437:                                     }
15438:                                     close(PIPE);
15439:                                 }
15440:                                 foreach my $key (sort {$b <=> $a } (keys(%newnums))) {
15441:                                     unless (exists($oldnums{$key})) {
15442:                                         $hadchanges = 1;
15443:                                         last;
15444:                                     }
15445:                                 }
15446:                                 unless ($hadchanges) {
15447:                                     foreach my $key (sort {$b <=> $a } (keys(%oldnums))) {
15448:                                         unless (exists($newnums{$key})) {
15449:                                             $hadchanges = 1;
15450:                                             last;
15451:                                         }
15452:                                     }
15453:                                 }
15454:                             }
15455:                         }
15456:                     } else {
15457:                         unlink($tmpcrl);
15458:                     }
15459:                 } else {
15460:                     unlink($tmpcrl);
15461:                 }
15462:             } else {
15463:                 unlink($tmpcrl);
15464:             }
15465:         }
15466:     }
15467:     return ($msg,$hadchanges);
15468: }
15469: 
15470: sub parse_getdns_url {
15471:     my ($command,$url) = @_;
15472:     my $dir = $perlvar{'lonTabDir'};
15473:     my $file;
15474:     if ($command eq 'hosts') {
15475:         $file = 'dns_hosts.tab';
15476:     } elsif ($command eq 'domain') {
15477:         $file = 'dns_domain.tab';
15478:     } elsif ($command eq 'checksums') {
15479:         my $version = (split('/',$url))[4];
15480:         $file = "dns_checksums/$version.tab",
15481:     } elsif ($command eq 'loncapaCRL') {
15482:         $dir = $perlvar{'lonCertificateDirectory'};
15483:         $file = $perlvar{'lonnetCertRevocationList'};
15484:     }
15485:     return ($dir,$file);
15486: }
15487: 
15488: # ------------------------------------------------------------ Read domain file
15489: {
15490:     my $loaded;
15491:     my %domain;
15492: 
15493:     sub parse_domain_tab {
15494: 	my ($lines) = @_;
15495: 	foreach my $line (@$lines) {
15496: 	    next if ($line =~ /^(\#|\s*$ )/x);
15497: 
15498: 	    chomp($line);
15499: 	    my ($name,@elements) = split(/:/,$line,9);
15500: 	    my %this_domain;
15501: 	    foreach my $field ('description', 'auth_def', 'auth_arg_def',
15502: 			       'lang_def', 'city', 'longi', 'lati',
15503: 			       'primary') {
15504: 		$this_domain{$field} = shift(@elements);
15505: 	    }
15506: 	    $domain{$name} = \%this_domain;
15507: 	}
15508:     }
15509: 
15510:     sub reset_domain_info {
15511: 	undef($loaded);
15512: 	undef(%domain);
15513:     }
15514: 
15515:     sub load_domain_tab {
15516: 	my ($ignore_cache,$nocache) = @_;
15517: 	&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);
15518: 	my $fh;
15519: 	if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) {
15520: 	    my @lines = <$fh>;
15521: 	    &parse_domain_tab(\@lines);
15522: 	}
15523: 	close($fh);
15524: 	$loaded = 1;
15525:     }
15526: 
15527:     sub domain {
15528: 	&load_domain_tab() if (!$loaded);
15529: 
15530: 	my ($name,$what) = @_;
15531: 	return if ( !exists($domain{$name}) );
15532: 
15533: 	if (!$what) {
15534: 	    return $domain{$name}{'description'};
15535: 	}
15536: 	return $domain{$name}{$what};
15537:     }
15538: 
15539:     sub domain_info {
15540:         &load_domain_tab() if (!$loaded);
15541:         return %domain;
15542:     }
15543: 
15544: }
15545: 
15546: 
15547: # ------------------------------------------------------------- Read hosts file
15548: {
15549:     my %hostname;
15550:     my %hostdom;
15551:     my %libserv;
15552:     my $loaded;
15553:     my %name_to_host;
15554:     my %internetdom;
15555:     my %LC_dns_serv;
15556: 
15557:     sub parse_hosts_tab {
15558: 	my ($file) = @_;
15559: 	foreach my $configline (@$file) {
15560: 	    next if ($configline =~ /^(\#|\s*$ )/x);
15561:             chomp($configline);
15562: 	    if ($configline =~ /^\^/) {
15563:                 if ($configline =~ /^\^([\w.\-]+)/) {
15564:                     $LC_dns_serv{$1} = 1;
15565:                 }
15566:                 next;
15567:             }
15568: 	    my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
15569: 	    $name=~s/\s//g;
15570: 	    if ($id && $domain && $role && $name) {
15571:                 if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
15572:                     my $curr = $hostname{$id};
15573:                     my $skip;
15574:                     if (ref($name_to_host{$curr}) eq 'ARRAY') {
15575:                         if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
15576:                             $skip = 1;
15577:                         } else {
15578:                             @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
15579:                         }
15580:                     }
15581:                     unless ($skip) {
15582:                         push(@{$name_to_host{$name}},$id);
15583:                     }
15584:                 } else {
15585:                     push(@{$name_to_host{$name}},$id);
15586:                 }
15587: 		$hostname{$id}=$name;
15588: 		$hostdom{$id}=$domain;
15589: 		if ($role eq 'library') { $libserv{$id}=$name; }
15590:                 if (defined($protocol)) {
15591:                     if ($protocol eq 'https') {
15592:                         $protocol{$id} = $protocol;
15593:                     } else {
15594:                         $protocol{$id} = 'http'; 
15595:                     }
15596:                 } else {
15597:                     $protocol{$id} = 'http';
15598:                 }
15599:                 if (defined($intdom)) {
15600:                     $internetdom{$id} = $intdom;
15601:                 }
15602: 	    }
15603: 	}
15604:     }
15605:     
15606:     sub reset_hosts_info {
15607: 	&purge_remembered();
15608: 	&reset_domain_info();
15609: 	&reset_hosts_ip_info();
15610:         undef(%internetdom);
15611: 	undef(%name_to_host);
15612: 	undef(%hostname);
15613: 	undef(%hostdom);
15614: 	undef(%libserv);
15615: 	undef($loaded);
15616:     }
15617: 
15618:     sub load_hosts_tab {
15619: 	my ($ignore_cache,$nocache) = @_;
15620: 	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);
15621: 	open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
15622: 	my @config = <$config>;
15623: 	&parse_hosts_tab(\@config);
15624: 	close($config);
15625: 	$loaded=1;
15626:     }
15627: 
15628:     sub hostname {
15629: 	&load_hosts_tab() if (!$loaded);
15630: 
15631: 	my ($lonid) = @_;
15632: 	return $hostname{$lonid};
15633:     }
15634: 
15635:     sub all_hostnames {
15636: 	&load_hosts_tab() if (!$loaded);
15637: 
15638: 	return %hostname;
15639:     }
15640: 
15641:     sub all_names {
15642:         my ($ignore_cache,$nocache) = @_;
15643: 	&load_hosts_tab($ignore_cache,$nocache) if (!$loaded);
15644: 
15645: 	return %name_to_host;
15646:     }
15647: 
15648:     sub all_host_domain {
15649:         &load_hosts_tab() if (!$loaded);
15650:         return %hostdom;
15651:     }
15652: 
15653:     sub all_host_intdom {
15654:         &load_hosts_tab() if (!$loaded);
15655:         return %internetdom;
15656:     }
15657: 
15658:     sub is_library {
15659: 	&load_hosts_tab() if (!$loaded);
15660: 
15661: 	return exists($libserv{$_[0]});
15662:     }
15663: 
15664:     sub all_library {
15665: 	&load_hosts_tab() if (!$loaded);
15666: 
15667: 	return %libserv;
15668:     }
15669: 
15670:     sub unique_library {
15671: 	#2x reverse removes all hostnames that appear more than once
15672:         my %unique = reverse &all_library();
15673:         return reverse %unique;
15674:     }
15675: 
15676:     sub get_servers {
15677: 	&load_hosts_tab() if (!$loaded);
15678: 
15679: 	my ($domain,$type) = @_;
15680: 	my %possible_hosts = ($type eq 'library') ? %libserv
15681: 	                                          : %hostname;
15682: 	my %result;
15683: 	if (ref($domain) eq 'ARRAY') {
15684: 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
15685: 		if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
15686: 		    $result{$host} = $hostname;
15687: 		}
15688: 	    }
15689: 	} else {
15690: 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
15691: 		if ($hostdom{$host} eq $domain) {
15692: 		    $result{$host} = $hostname;
15693: 		}
15694: 	    }
15695: 	}
15696: 	return %result;
15697:     }
15698: 
15699:     sub get_unique_servers {
15700:         my %unique = reverse &get_servers(@_);
15701: 	return reverse %unique;
15702:     }
15703: 
15704:     sub host_domain {
15705: 	&load_hosts_tab() if (!$loaded);
15706: 
15707: 	my ($lonid) = @_;
15708: 	return $hostdom{$lonid};
15709:     }
15710: 
15711:     sub all_domains {
15712: 	&load_hosts_tab() if (!$loaded);
15713: 
15714: 	my %seen;
15715: 	my @uniq = grep(!$seen{$_}++, values(%hostdom));
15716: 	return @uniq;
15717:     }
15718: 
15719:     sub internet_dom {
15720:         &load_hosts_tab() if (!$loaded);
15721: 
15722:         my ($lonid) = @_;
15723:         return $internetdom{$lonid};
15724:     }
15725: 
15726:     sub is_LC_dns {
15727:         &load_hosts_tab() if (!$loaded);
15728: 
15729:         my ($hostname) = @_;
15730:         return exists($LC_dns_serv{$hostname});
15731:     }
15732: 
15733: }
15734: 
15735: { 
15736:     my %iphost;
15737:     my %name_to_ip;
15738:     my %lonid_to_ip;
15739: 
15740:     sub get_hosts_from_ip {
15741: 	my ($ip) = @_;
15742: 	my %iphosts = &get_iphost();
15743: 	if (ref($iphosts{$ip})) {
15744: 	    return @{$iphosts{$ip}};
15745: 	}
15746: 	return;
15747:     }
15748:     
15749:     sub reset_hosts_ip_info {
15750: 	undef(%iphost);
15751: 	undef(%name_to_ip);
15752: 	undef(%lonid_to_ip);
15753:     }
15754: 
15755:     sub get_host_ip {
15756: 	my ($lonid) = @_;
15757: 	if (exists($lonid_to_ip{$lonid})) {
15758: 	    return $lonid_to_ip{$lonid};
15759: 	}
15760: 	my $name=&hostname($lonid);
15761:    	my $ip = gethostbyname($name);
15762: 	return if (!$ip || length($ip) ne 4);
15763: 	$ip=inet_ntoa($ip);
15764: 	$name_to_ip{$name}   = $ip;
15765: 	$lonid_to_ip{$lonid} = $ip;
15766: 	return $ip;
15767:     }
15768:     
15769:     sub get_iphost {
15770: 	my ($ignore_cache,$nocache) = @_;
15771: 
15772: 	if (!$ignore_cache) {
15773: 	    if (%iphost) {
15774: 		return %iphost;
15775: 	    }
15776: 	    my ($ip_info,$cached)=
15777: 		&is_cached_new('iphost','iphost');
15778: 	    if ($cached) {
15779: 		%iphost      = %{$ip_info->[0]};
15780: 		%name_to_ip  = %{$ip_info->[1]};
15781: 		%lonid_to_ip = %{$ip_info->[2]};
15782: 		return %iphost;
15783: 	    }
15784: 	}
15785: 
15786: 	# get yesterday's info for fallback
15787: 	my %old_name_to_ip;
15788: 	my ($ip_info,$cached)=
15789: 	    &is_cached_new('iphost','iphost');
15790: 	if ($cached) {
15791: 	    %old_name_to_ip = %{$ip_info->[1]};
15792: 	}
15793: 
15794: 	my %name_to_host = &all_names($ignore_cache,$nocache);
15795: 	foreach my $name (keys(%name_to_host)) {
15796: 	    my $ip;
15797: 	    if (!exists($name_to_ip{$name})) {
15798: 		$ip = gethostbyname($name);
15799: 		if (!$ip || length($ip) ne 4) {
15800: 		    if (defined($old_name_to_ip{$name})) {
15801: 			$ip = $old_name_to_ip{$name};
15802: 			&logthis("Can't find $name defaulting to old $ip");
15803: 		    } else {
15804: 			&logthis("Name $name no IP found");
15805: 			next;
15806: 		    }
15807: 		} else {
15808: 		    $ip=inet_ntoa($ip);
15809: 		}
15810: 		$name_to_ip{$name} = $ip;
15811: 	    } else {
15812: 		$ip = $name_to_ip{$name};
15813: 	    }
15814: 	    foreach my $id (@{ $name_to_host{$name} }) {
15815: 		$lonid_to_ip{$id} = $ip;
15816: 	    }
15817: 	    push(@{$iphost{$ip}},@{$name_to_host{$name}});
15818: 	}
15819:         unless ($nocache) {
15820: 	    &do_cache_new('iphost','iphost',
15821: 		          [\%iphost,\%name_to_ip,\%lonid_to_ip],
15822: 		          48*60*60);
15823:         }
15824: 
15825: 	return %iphost;
15826:     }
15827: 
15828:     #
15829:     #  Given a DNS returns the loncapa host name for that DNS 
15830:     # 
15831:     sub host_from_dns {
15832:         my ($dns) = @_;
15833:         my @hosts;
15834:         my $ip;
15835: 
15836:         if (exists($name_to_ip{$dns})) {
15837:             $ip = $name_to_ip{$dns};
15838:         }
15839:         if (!$ip) {
15840:             $ip = gethostbyname($dns); # Initial translation to IP is in net order.
15841:             if (length($ip) == 4) { 
15842: 	        $ip   = &IO::Socket::inet_ntoa($ip);
15843:             }
15844:         }
15845:         if ($ip) {
15846: 	    @hosts = get_hosts_from_ip($ip);
15847: 	    return $hosts[0];
15848:         }
15849:         return undef;
15850:     }
15851: 
15852:     sub get_internet_names {
15853:         my ($lonid) = @_;
15854:         return if ($lonid eq '');
15855:         my ($idnref,$cached)=
15856:             &is_cached_new('internetnames',$lonid);
15857:         if ($cached) {
15858:             return $idnref;
15859:         }
15860:         my $ip = &get_host_ip($lonid);
15861:         my @hosts = &get_hosts_from_ip($ip);
15862:         my %iphost = &get_iphost();
15863:         my (@idns,%seen);
15864:         foreach my $id (@hosts) {
15865:             my $dom = &host_domain($id);
15866:             my $prim_id = &domain($dom,'primary');
15867:             my $prim_ip = &get_host_ip($prim_id);
15868:             next if ($seen{$prim_ip});
15869:             if (ref($iphost{$prim_ip}) eq 'ARRAY') {
15870:                 foreach my $id (@{$iphost{$prim_ip}}) {
15871:                     my $intdom = &internet_dom($id);
15872:                     unless (grep(/^\Q$intdom\E$/,@idns)) {
15873:                         push(@idns,$intdom);
15874:                     }
15875:                 }
15876:             }
15877:             $seen{$prim_ip} = 1;
15878:         }
15879:         return &do_cache_new('internetnames',$lonid,\@idns,12*60*60);
15880:     }
15881: 
15882: }
15883: 
15884: sub all_loncaparevs {
15885:     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
15886: }
15887: 
15888: # ---------------------------------------------------------- Read loncaparev table
15889: {
15890:     sub load_loncaparevs { 
15891:         if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
15892:             if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {
15893:                 while (my $configline=<$config>) {
15894:                     chomp($configline);
15895:                     my ($hostid,$loncaparev)=split(/:/,$configline);
15896:                     $loncaparevs{$hostid}=$loncaparev;
15897:                 }
15898:                 close($config);
15899:             }
15900:         }
15901:     }
15902: }
15903: 
15904: # ---------------------------------------------------------- Read serverhostID table
15905: {
15906:     sub load_serverhomeIDs {
15907:         if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
15908:             if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
15909:                 while (my $configline=<$config>) {
15910:                     chomp($configline);
15911:                     my ($name,$id)=split(/:/,$configline);
15912:                     $serverhomeIDs{$name}=$id;
15913:                 }
15914:                 close($config);
15915:             }
15916:         }
15917:     }
15918: }
15919: 
15920: 
15921: BEGIN {
15922: 
15923: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
15924:     unless ($readit) {
15925: {
15926:     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
15927:     %perlvar = (%perlvar,%{$configvars});
15928: }
15929: 
15930: 
15931: # ------------------------------------------------------ Read spare server file
15932: {
15933:     open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab");
15934: 
15935:     while (my $configline=<$config>) {
15936:        chomp($configline);
15937:        if ($configline) {
15938: 	   my ($host,$type) = split(':',$configline,2);
15939: 	   if (!defined($type) || $type eq '') { $type = 'default' };
15940: 	   push(@{ $spareid{$type} }, $host);
15941:        }
15942:     }
15943:     close($config);
15944: }
15945: # ------------------------------------------------------------ Read permissions
15946: {
15947:     open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");
15948: 
15949:     while (my $configline=<$config>) {
15950: 	chomp($configline);
15951: 	if ($configline) {
15952: 	    my ($role,$perm)=split(/ /,$configline);
15953: 	    if ($perm ne '') { $pr{$role}=$perm; }
15954: 	}
15955:     }
15956:     close($config);
15957: }
15958: 
15959: # -------------------------------------------- Read plain texts for permissions
15960: {
15961:     open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab");
15962: 
15963:     while (my $configline=<$config>) {
15964: 	chomp($configline);
15965: 	if ($configline) {
15966: 	    my ($short,@plain)=split(/:/,$configline);
15967:             %{$prp{$short}} = ();
15968: 	    if (@plain > 0) {
15969:                 $prp{$short}{'std'} = $plain[0];
15970:                 for (my $i=1; $i<@plain; $i++) {
15971:                     $prp{$short}{'alt'.$i} = $plain[$i];  
15972:                 }
15973:             }
15974: 	}
15975:     }
15976:     close($config);
15977: }
15978: 
15979: # ---------------------------------------------------------- Read package table
15980: {
15981:     open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab");
15982: 
15983:     while (my $configline=<$config>) {
15984: 	if ($configline !~ /\S/ || $configline=~/^#/) { next; }
15985: 	chomp($configline);
15986: 	my ($short,$plain)=split(/:/,$configline);
15987: 	my ($pack,$name)=split(/\&/,$short);
15988: 	if ($plain ne '') {
15989: 	    $packagetab{$pack.'&'.$name.'&name'}=$name; 
15990: 	    $packagetab{$short}=$plain; 
15991: 	}
15992:     }
15993:     close($config);
15994: }
15995: 
15996: # ---------------------------------------------------------- Read loncaparev table
15997: 
15998: &load_loncaparevs();
15999: 
16000: # ---------------------------------------------------------- Read serverhostID table
16001: 
16002: &load_serverhomeIDs();
16003: 
16004: # ---------------------------------------------------------- Read releaseslist XML
16005: {
16006:     my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';
16007:     if (-e $file) {
16008:         my $parser = HTML::LCParser->new($file);
16009:         while (my $token = $parser->get_token()) {
16010:             if ($token->[0] eq 'S') {
16011:                 my $item = $token->[1];
16012:                 my $name = $token->[2]{'name'};
16013:                 my $value = $token->[2]{'value'};
16014:                 my $valuematch = $token->[2]{'valuematch'};
16015:                 my $namematch = $token->[2]{'namematch'};
16016:                 if ($item eq 'parameter') {
16017:                     if (($namematch ne '') || (($name ne '') && ($value ne '' || $valuematch ne ''))) {
16018:                         my $release = $parser->get_text();
16019:                         $release =~ s/(^\s*|\s*$ )//gx;
16020:                         $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release;
16021:                     }
16022:                 } elsif ($item ne '' && $name ne '') {
16023:                     my $release = $parser->get_text();
16024:                     $release =~ s/(^\s*|\s*$ )//gx;
16025:                     $needsrelease{$item.':'.$name.':'.$value} = $release;
16026:                 }
16027:             }
16028:         }
16029:     }
16030: }
16031: 
16032: # ---------------------------------------------------------- Read managers table
16033: {
16034:     if (-e "$perlvar{'lonTabDir'}/managers.tab") {
16035:         if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) {
16036:             while (my $configline=<$config>) {
16037:                 chomp($configline);
16038:                 next if ($configline =~ /^\#/);
16039:                 if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) {
16040:                     $managerstab{$configline} = 1;
16041:                 }
16042:             }
16043:             close($config);
16044:         }
16045:     }
16046: }
16047: 
16048: # ------------- set up temporary directory
16049: {
16050:     $tmpdir = LONCAPA::tempdir();
16051: 
16052: }
16053: 
16054: # ------------- set default texengine (domain default overrides this)
16055: {
16056:     $deftex = LONCAPA::texengine();
16057: }
16058: 
16059: # ------------- set default minimum length for passwords for internal auth users
16060: {
16061:     $passwdmin = LONCAPA::passwd_min();
16062: }
16063: 
16064: $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
16065: 				'compress_threshold'=> 20_000,
16066:  			        });
16067: 
16068: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
16069: $dumpcount=0;
16070: $locknum=0;
16071: 
16072: &logtouch();
16073: &logthis('<font color="yellow">INFO: Read configuration</font>');
16074: $readit=1;
16075:     {
16076: 	use integer;
16077: 	my $test=(2**32)+1;
16078: 	if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
16079: 	&logthis(" Detected 64bit platform ($_64bit)");
16080:     }
16081: }
16082: }
16083: 
16084: 1;
16085: __END__
16086: 
16087: =pod
16088: 
16089: =head1 NAME
16090: 
16091: Apache::lonnet - Subroutines to ask questions about things in the network.
16092: 
16093: =head1 SYNOPSIS
16094: 
16095: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
16096: 
16097:  &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
16098: 
16099: Common parameters:
16100: 
16101: =over 4
16102: 
16103: =item *
16104: 
16105: $uname : an internal username (if $cname expecting a course Id specifically)
16106: 
16107: =item *
16108: 
16109: $udom : a domain (if $cdom expecting a course's domain specifically)
16110: 
16111: =item *
16112: 
16113: $symb : a resource instance identifier
16114: 
16115: =item *
16116: 
16117: $namespace : the name of a .db file that contains the data needed or
16118: being set.
16119: 
16120: =back
16121: 
16122: =head1 OVERVIEW
16123: 
16124: lonnet provides subroutines which interact with the
16125: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
16126: about classes, users, and resources.
16127: 
16128: For many of these objects you can also use this to store data about
16129: them or modify them in various ways.
16130: 
16131: =head2 Symbs
16132: 
16133: To identify a specific instance of a resource, LON-CAPA uses symbols
16134: or "symbs"X<symb>. These identifiers are built from the URL of the
16135: map, the resource number of the resource in the map, and the URL of
16136: the resource itself. The latter is somewhat redundant, but might help
16137: if maps change.
16138: 
16139: An example is
16140: 
16141:  msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
16142: 
16143: The respective map entry is
16144: 
16145:  <resource id="19" src="/res/msu/korte/tests/part12.problem"
16146:   title="Problem 2">
16147:  </resource>
16148: 
16149: Symbs are used by the random number generator, as well as to store and
16150: restore data specific to a certain instance of for example a problem.
16151: 
16152: =head2 Storing And Retrieving Data
16153: 
16154: X<store()>X<cstore()>X<restore()>Three of the most important functions
16155: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
16156: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
16157: is is the non-critical message twin of cstore. These functions are for
16158: handlers to store a perl hash to a user's permanent data space in an
16159: easy manner, and to retrieve it again on another call. It is expected
16160: that a handler would use this once at the beginning to retrieve data,
16161: and then again once at the end to send only the new data back.
16162: 
16163: The data is stored in the user's data directory on the user's
16164: homeserver under the ID of the course.
16165: 
16166: The hash that is returned by restore will have all of the previous
16167: value for all of the elements of the hash.
16168: 
16169: Example:
16170: 
16171:  #creating a hash
16172:  my %hash;
16173:  $hash{'foo'}='bar';
16174: 
16175:  #storing it
16176:  &Apache::lonnet::cstore(\%hash);
16177: 
16178:  #changing a value
16179:  $hash{'foo'}='notbar';
16180: 
16181:  #adding a new value
16182:  $hash{'bar'}='foo';
16183:  &Apache::lonnet::cstore(\%hash);
16184: 
16185:  #retrieving the hash
16186:  my %history=&Apache::lonnet::restore();
16187: 
16188:  #print the hash
16189:  foreach my $key (sort(keys(%history))) {
16190:    print("\%history{$key} = $history{$key}");
16191:  }
16192: 
16193: Will print out:
16194: 
16195:  %history{1:foo} = bar
16196:  %history{1:keys} = foo:timestamp
16197:  %history{1:timestamp} = 990455579
16198:  %history{2:bar} = foo
16199:  %history{2:foo} = notbar
16200:  %history{2:keys} = foo:bar:timestamp
16201:  %history{2:timestamp} = 990455580
16202:  %history{bar} = foo
16203:  %history{foo} = notbar
16204:  %history{timestamp} = 990455580
16205:  %history{version} = 2
16206: 
16207: Note that the special hash entries C<keys>, C<version> and
16208: C<timestamp> were added to the hash. C<version> will be equal to the
16209: total number of versions of the data that have been stored. The
16210: C<timestamp> attribute will be the UNIX time the hash was
16211: stored. C<keys> is available in every historical section to list which
16212: keys were added or changed at a specific historical revision of a
16213: hash.
16214: 
16215: B<Warning>: do not store the hash that restore returns directly. This
16216: will cause a mess since it will restore the historical keys as if the
16217: were new keys. I.E. 1:foo will become 1:1:foo etc.
16218: 
16219: Calling convention:
16220: 
16221:  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
16222:  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore);
16223: 
16224: For more detailed information, see lonnet specific documentation.
16225: 
16226: =head1 RETURN MESSAGES
16227: 
16228: =over 4
16229: 
16230: =item * B<con_lost>: unable to contact remote host
16231: 
16232: =item * B<con_delayed>: unable to contact remote host, message will be delivered
16233: when the connection is brought back up
16234: 
16235: =item * B<con_failed>: unable to contact remote host and unable to save message
16236: for later delivery
16237: 
16238: =item * B<error:>: an error a occurred, a description of the error follows the :
16239: 
16240: =item * B<no_such_host>: unable to fund a host associated with the user/domain
16241: that was requested
16242: 
16243: =back
16244: 
16245: =head1 PUBLIC SUBROUTINES
16246: 
16247: =head2 Session Environment Functions
16248: 
16249: =over 4
16250: 
16251: =item * 
16252: X<appenv()>
16253: B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to
16254: the user envirnoment file, and will be restored for each access this
16255: user makes during this session, also modifies the %env for the current
16256: process. Optional rolesarrayref - if defined contains a reference to an array
16257: of roles which are exempt from the restriction on modifying user.role entries 
16258: in the user's environment.db and in %env.    
16259: 
16260: =item *
16261: X<delenv()>
16262: B<delenv($delthis,$regexp)>: removes all items from the session
16263: environment file that begin with $delthis. If the 
16264: optional second arg - $regexp - is true, $delthis is treated as a 
16265: regular expression, otherwise \Q$delthis\E is used. 
16266: The values are also deleted from the current processes %env.
16267: 
16268: =item * get_env_multiple($name) 
16269: 
16270: gets $name from the %env hash, it seemlessly handles the cases where multiple
16271: values may be defined and end up as an array ref.
16272: 
16273: returns an array of values
16274: 
16275: =back
16276: 
16277: =head2 User Information
16278: 
16279: =over 4
16280: 
16281: =item *
16282: X<queryauthenticate()>
16283: B<queryauthenticate($uname,$udom)>: try to determine user's current 
16284: authentication scheme
16285: 
16286: =item *
16287: X<authenticate()>
16288: B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to
16289: authenticate user from domain's lib servers (first use the current
16290: one). C<$upass> should be the users password.
16291: $checkdefauth is optional (value is 1 if a check should be made to
16292:    authenticate user using default authentication method, and allow
16293:    account creation if username does not have account in the domain).
16294: $clientcancheckhost is optional (value is 1 if checking whether the
16295:    server can host will occur on the client side in lonauth.pm).   
16296: 
16297: =item *
16298: X<homeserver()>
16299: B<homeserver($uname,$udom)>: find the server which has
16300: the user's directory and files (there must be only one), this caches
16301: the answer, and also caches if there is a borken connection.
16302: 
16303: =item *
16304: X<idget()>
16305: B<idget($udom,$idsref,$namespace)>: find the usernames behind either 
16306: a list of student/employee IDs or clicker IDs
16307: (student/employee IDs are a unique resource in a domain, there must be 
16308: only 1 ID per username, and only 1 username per ID in a specific domain).
16309: clickerIDs are not necessarily unique, as students might share clickers.
16310: (returns hash: id=>name,id=>name)
16311: 
16312: =item *
16313: X<idrget()>
16314: B<idrget($udom,@unames)>: find the IDs behind a list of
16315: usernames (returns hash: name=>id,name=>id)
16316: 
16317: =item *
16318: X<idput()>
16319: B<idput($udom,$idsref,$uhome,$namespace)>: store away a list of 
16320: names and associated student/employee IDs or clicker IDs.
16321: 
16322: =item *
16323: X<iddel()>
16324: B<iddel($udom,$idshashref,$uhome,$namespace)>: delete unwanted 
16325: student/employee ID or clicker ID username look-ups from domain.
16326: The homeserver ($uhome) and namespace ($namespace) are optional.
16327: If no $uhome is provided, it will be determined usig &homeserver()
16328: for each user.  If no $namespace is provided, the default is ids.
16329: 
16330: =item *
16331: X<updateclickers()>
16332: B<updateclickers($udom,$action,$idshashref,$uhome,$critical)>: update 
16333: clicker ID-to-username look-ups in clickers.db on library server.
16334: Permitted actions are add or del (i.e., add or delete). The 
16335: clickers.db contains clickerID as keys (escaped), and each corresponding
16336: value is an escaped comma-separated list of usernames (for whom the
16337: library server is the homeserver), who registered that particular ID.
16338: If $critical is true, the update will be sent via &critical, otherwise
16339: &reply() will be used.
16340: 
16341: =item *
16342: X<rolesinit()>
16343: B<rolesinit($udom,$username)>: get user privileges.
16344: returns user role, first access and timer interval hashes
16345: 
16346: =item *
16347: X<privileged()>
16348: B<privileged($username,$domain)>: returns a true if user has a
16349: privileged and active role (i.e. su or dc), false otherwise.
16350: 
16351: =item *
16352: X<getsection()>
16353: B<getsection($udom,$uname,$cname)>: finds the section of student in the
16354: course $cname, return section name/number or '' for "not in course"
16355: and '-1' for "no section"
16356: 
16357: =item *
16358: X<userenvironment()>
16359: B<userenvironment($udom,$uname,@what)>: gets the values of the keys
16360: passed in @what from the requested user's environment, returns a hash
16361: 
16362: =item * 
16363: X<userlog_query()>
16364: B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
16365: activity.log file. %filters defines filters applied when parsing the
16366: log file. These can be start or end timestamps, or the type of action
16367: - log to look for Login or Logout events, check for Checkin or
16368: Checkout, role for role selection. The response is in the form
16369: timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are
16370: escaped strings of the action recorded in the activity.log file.
16371: 
16372: =back
16373: 
16374: =head2 User Roles
16375: 
16376: =over 4
16377: 
16378: =item *
16379: 
16380: allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; 
16381: returns codes for allowed actions.
16382: 
16383: The first argument is required, all others are optional.
16384: 
16385: $priv is the privilege being checked.
16386: $uri contains additional information about what is being checked for access (e.g.,
16387: URL, course ID etc.). 
16388: $symb is the unique resource instance identifier in a course; if needed,
16389: but not provided, it will be retrieved via a call to &symbread(). 
16390: $role is the role for which a priv is being checked (only used if priv is evb). 
16391: $clientip is the user's IP address (only used when checking for access to portfolio 
16392: files).
16393: $noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This 
16394: prevents recursive calls to &allowed.
16395: 
16396:  F: full access
16397:  U,I,K: authentication modes (cxx only)
16398:  '': forbidden
16399:  1: user needs to choose course
16400:  2: browse allowed
16401:  A: passphrase authentication needed
16402:  B: access temporarily blocked because of a blocking event in a course.
16403:  D: access blocked because access is required via session initiated via deep-link 
16404: 
16405: =item *
16406: 
16407: constructaccess($url,$setpriv) : check for access to construction space URL
16408: 
16409: See if the owner domain and name in the URL match those in the
16410: expected environment.  If so, return three element list
16411: ($ownername,$ownerdomain,$ownerhome).
16412: 
16413: Otherwise return the null string.
16414: 
16415: If second argument 'setpriv' is true, it assigns the privileges,
16416: and returns the same three element list, unless the owner has
16417: blocked "ad hoc" Domain Coordinator access to the Author Space,
16418: in which case the null string is returned.
16419: 
16420: =item *
16421: 
16422: definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role;
16423: define a custom role rolename set privileges in format of lonTabs/roles.tab
16424: for system, domain, and course level. $uname and $udom are optional (current
16425: user's username and domain will be used when either of $uname or $udom are absent.
16426: 
16427: =item *
16428: 
16429: plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash 
16430: (rolesplain.tab); plain text explanation of a user role term.
16431: $type is Course (default) or Community.
16432: If $forcedefault evaluates to true, text returned will be default 
16433: text for $type. Otherwise, if this is a course, the text returned 
16434: will be a custom name for the role (if defined in the course's 
16435: environment).  If no custom name is defined the default is returned.
16436:    
16437: =item *
16438: 
16439: get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) :
16440: All arguments are optional. Returns a hash of a roles, either for
16441: co-author/assistant author roles for a user's Construction Space
16442: (default), or if $context is 'userroles', roles for the user himself,
16443: In the hash, keys are set to colon-separated $uname,$udom,$role, and
16444: (optionally) if $withsec is true, a fourth colon-separated item - $section.
16445: For each key, value is set to colon-separated start and end times for
16446: the role.  If no username and domain are specified, will default to
16447: current user/domain. Types, roles, and roledoms are references to arrays
16448: of role statuses (active, future or previous), roles 
16449: (e.g., cc,in, st etc.) and domains of the roles which can be used
16450: to restrict the list of roles reported. If no array ref is 
16451: provided for types, will default to return only active roles.
16452: 
16453: =item *
16454: 
16455: in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
16456: user: $uname:$udom has a role in the course: $cdom_$cnum. 
16457: 
16458: Additional optional arguments are: $type (if role checking is to be restricted 
16459: to certain user status types -- previous (expired roles), active (currently
16460: available roles) or future (roles available in the future), and
16461: $hideprivileged -- if true will not report course roles for users who
16462: have active Domain Coordinator role in course's domain or in additional
16463: domains (specified in 'Domains to check for privileged users' in course
16464: environment -- set via:  Course Settings -> Classlists and staff listing).
16465: 
16466: =item *
16467: 
16468: privileged($username,$domain,$possdomains,$possroles) : returns 1 if user
16469: $username:$domain is a privileged user (e.g., Domain Coordinator or Super User)
16470: $possdomains and $possroles are optional array refs -- to domains to check and
16471: roles to check.  If $possdomains is not specified, a dump will be done of the
16472: users' roles.db to check for a dc or su role in any domain. This can be
16473: time consuming if &privileged is called repeatedly (e.g., when displaying a
16474: classlist), so in such cases, supplying a $possdomains array is preferred, as
16475: this then allows &privileged_by_domain() to be used, which caches the identity
16476: of privileged users, eliminating the need for repeated calls to &dump().
16477: 
16478: =item *
16479: 
16480: privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash,
16481: where the outer hash keys are domains specified in the $possdomains array ref,
16482: next inner hash keys are privileged roles specified in the $roles array ref,
16483: and the innermost hash contains key = value pairs for username:domain = end:start
16484: for active or future "privileged" users with that role in that domain. To avoid
16485: repeated dumps of domain roles -- via &get_domain_roles() -- contents of the
16486: innerhash are cached using priv_$role and $dom as the identifiers.
16487: 
16488: =back
16489: 
16490: =head2 User Modification
16491: 
16492: =over 4
16493: 
16494: =item *
16495: 
16496: assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
16497: user for the level given by URL.  Optional start and end dates (leave empty
16498: string or zero for "no date")
16499: 
16500: =item *
16501: 
16502: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
16503: change a users, password, possible return values are: ok,
16504: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
16505: refused
16506: 
16507: =item *
16508: 
16509: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
16510: 
16511: =item *
16512: 
16513: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene,
16514:            $forceid,$desiredhome,$email,$inststatus,$candelete) :
16515: 
16516: will update user information (firstname,middlename,lastname,generation,
16517: permanentemail), and if forceid is true, student/employee ID also.
16518: A user's institutional affiliation(s) can also be updated.
16519: User information fields will not be overwritten with empty entries 
16520: unless the field is included in the $candelete array reference.
16521: This array is included when a single user is modified via "Manage Users",
16522: or when Autoupdate.pl is run by cron in a domain.
16523: 
16524: =item *
16525: 
16526: modifystudent
16527: 
16528: modify a student's enrollment and identification information.
16529: The course id is resolved based on the current user's environment.  
16530: This means the invoking user must be a course coordinator or otherwise
16531: associated with a course.
16532: 
16533: This call is essentially a wrapper for lonnet::modifyuser and
16534: lonnet::modify_student_enrollment
16535: 
16536: Inputs: 
16537: 
16538: =over 4
16539: 
16540: =item B<$udom> Student's loncapa domain
16541: 
16542: =item B<$uname> Student's loncapa login name
16543: 
16544: =item B<$uid> Student/Employee ID
16545: 
16546: =item B<$umode> Student's authentication mode
16547: 
16548: =item B<$upass> Student's password
16549: 
16550: =item B<$first> Student's first name
16551: 
16552: =item B<$middle> Student's middle name
16553: 
16554: =item B<$last> Student's last name
16555: 
16556: =item B<$gene> Student's generation
16557: 
16558: =item B<$usec> Student's section in course
16559: 
16560: =item B<$end> Unix time of the roles expiration
16561: 
16562: =item B<$start> Unix time of the roles start date
16563: 
16564: =item B<$forceid> If defined, allow $uid to be changed
16565: 
16566: =item B<$desiredhome> server to use as home server for student
16567: 
16568: =item B<$email> Student's permanent e-mail address
16569: 
16570: =item B<$type> Type of enrollment (auto or manual)
16571: 
16572: =item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto    
16573: 
16574: =item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
16575: 
16576: =item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
16577: 
16578: =item B<$context> role change context (shown in User Management Logs display in a course)
16579: 
16580: =item B<$inststatus> institutional status of user - : separated string of escaped status types
16581: 
16582: =item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class.
16583: 
16584: =back
16585: 
16586: =item *
16587: 
16588: modify_student_enrollment
16589: 
16590: Change a student's enrollment status in a class.  The environment variable
16591: 'role.request.course' must be defined for this function to proceed.
16592: 
16593: Inputs:
16594: 
16595: =over 4
16596: 
16597: =item $udom, student's domain
16598: 
16599: =item $uname, student's name
16600: 
16601: =item $uid, student's user id
16602: 
16603: =item $first, student's first name
16604: 
16605: =item $middle
16606: 
16607: =item $last
16608: 
16609: =item $gene
16610: 
16611: =item $usec
16612: 
16613: =item $end
16614: 
16615: =item $start
16616: 
16617: =item $type
16618: 
16619: =item $locktype
16620: 
16621: =item $cid
16622: 
16623: =item $selfenroll
16624: 
16625: =item $context
16626: 
16627: =item $credits, number of credits student will earn from this class
16628: 
16629: =item $instsec, institutional course section code for student
16630: 
16631: =back
16632: 
16633: 
16634: =item *
16635: 
16636: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
16637: custom role; give a custom role to a user for the level given by URL.  Specify
16638: name and domain of role author, and role name
16639: 
16640: =item *
16641: 
16642: revokerole($udom,$uname,$url,$role) : revoke a role for url
16643: 
16644: =item *
16645: 
16646: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
16647: 
16648: =back
16649: 
16650: =head2 Course Infomation
16651: 
16652: =over 4
16653: 
16654: =item *
16655: 
16656: coursedescription($courseid,$options) : returns a hash of information about the
16657: specified course id, including all environment settings for the
16658: course, the description of the course will be in the hash under the
16659: key 'description'
16660: 
16661: $options is an optional parameter that if supplied is a hash reference that controls
16662: what how this function works.  It has the following key/values:
16663: 
16664: =over 4
16665: 
16666: =item freshen_cache
16667: 
16668: If defined, and the environment cache for the course is valid, it is 
16669: returned in the returned hash.
16670: 
16671: =item one_time
16672: 
16673: If defined, the last cache time is set to _now_
16674: 
16675: =item user
16676: 
16677: If defined, the supplied username is used instead of the current user.
16678: 
16679: 
16680: =back
16681: 
16682: =item *
16683: 
16684: resdata($name,$domain,$type,@which) : request for current parameter
16685: setting for a specific $type, where $type is either 'course' or 'user',
16686: @what should be a list of parameters to ask about. This routine caches
16687: answers for 10 minutes.
16688: 
16689: =item *
16690: 
16691: get_courseresdata($courseid, $domain) : dump the entire course resource
16692: data base, returning a hash that is keyed by the resource name and has
16693: values that are the resource value.  I believe that the timestamps and
16694: versions are also returned.
16695: 
16696: =back
16697: 
16698: =head2 Course Modification
16699: 
16700: =over 4
16701: 
16702: =item *
16703: 
16704: writecoursepref($courseid,%prefs) : write preferences (environment
16705: database) for a course
16706: 
16707: =item *
16708: 
16709: createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
16710: 
16711: =item *
16712: 
16713: generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
16714: 
16715: =item *
16716: 
16717: is_course($courseid), is_course($cdom, $cnum)
16718: 
16719: Accepts either a combined $courseid (in the form of domain_courseid) or the
16720: two component version $cdom, $cnum. It checks if the specified course exists.
16721: 
16722: Returns:
16723:     undef if the course doesn't exist, otherwise
16724:     in scalar context the combined courseid.
16725:     in list context the two components of the course identifier, domain and 
16726:     courseid.    
16727: 
16728: =back
16729: 
16730: =head2 Bubblesheet Configuration
16731: 
16732: =over 4
16733: 
16734: =item *
16735: 
16736: get_scantron_config($which)
16737: 
16738: $which - the name of the configuration to parse from the file.
16739: 
16740: Parses and returns the bubblesheet configuration line selected as a
16741: hash of configuration file fields.
16742: 
16743: 
16744: Returns:
16745:     If the named configuration is not in the file, an empty
16746:     hash is returned.
16747: 
16748:     a hash with the fields
16749:       name         - internal name for the this configuration setup
16750:       description  - text to display to operator that describes this config
16751:       CODElocation - if 0 or the string 'none'
16752:                           - no CODE exists for this config
16753:                      if -1 || the string 'letter'
16754:                           - a CODE exists for this config and is
16755:                             a string of letters
16756:                      Unsupported value (but planned for future support)
16757:                           if a positive integer
16758:                                - The CODE exists as the first n items from
16759:                                  the question section of the form
16760:                           if the string 'number'
16761:                                - The CODE exists for this config and is
16762:                                  a string of numbers
16763:       CODEstart   - (only matter if a CODE exists) column in the line where
16764:                      the CODE starts
16765:       CODElength  - length of the CODE
16766:       IDstart     - column where the student/employee ID starts
16767:       IDlength    - length of the student/employee ID info
16768:       Qstart      - column where the information from the bubbled
16769:                     'questions' start
16770:       Qlength     - number of columns comprising a single bubble line from
16771:                     the sheet. (usually either 1 or 10)
16772:       Qon         - either a single character representing the character used
16773:                     to signal a bubble was chosen in the positional setup, or
16774:                     the string 'letter' if the letter of the chosen bubble is
16775:                     in the final, or 'number' if a number representing the
16776:                     chosen bubble is in the file (1->A 0->J)
16777:       Qoff        - the character used to represent that a bubble was
16778:                     left blank
16779:       PaperID     - if the scanning process generates a unique number for each
16780:                     sheet scanned the column that this ID number starts in
16781:       PaperIDlength - number of columns that comprise the unique ID number
16782:                       for the sheet of paper
16783:       FirstName   - column that the first name starts in
16784:       FirstNameLength - number of columns that the first name spans
16785:       LastName    - column that the last name starts in
16786:       LastNameLength - number of columns that the last name spans
16787:       BubblesPerRow - number of bubbles available in each row used to
16788:                       bubble an answer. (If not specified, 10 assumed).
16789: 
16790: 
16791: =item *
16792: 
16793: get_scantronformat_file($cdom)
16794: 
16795: $cdom - the course's domain (optional); if not supplied, uses
16796: domain for current $env{'request.course.id'}.
16797: 
16798: Returns an array containing lines from the scantron format file for
16799: the domain of the course.
16800: 
16801: If a url for a custom.tab file is listed in domain's configuration.db,
16802: lines are from this file.
16803: 
16804: Otherwise, if a default.tab has been published in RES space by the
16805: domainconfig user, lines are from this file.
16806: 
16807: Otherwise, fall back to getting lines from the legacy file on the
16808: local server:  /home/httpd/lonTabs/default_scantronformat.tab
16809: 
16810: =back
16811: 
16812: =head2 Resource Subroutines
16813: 
16814: =over 4
16815: 
16816: =item *
16817: 
16818: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
16819: 
16820: =item *
16821: 
16822: repcopy($filename) : subscribes to the requested file, and attempts to
16823: replicate from the owning library server, Might return
16824: 'unavailable', 'not_found', 'forbidden', 'ok', or
16825: 'bad_request', also attempts to grab the metadata for the
16826: resource. Expects the local filesystem pathname
16827: (/home/httpd/html/res/....)
16828: 
16829: =back
16830: 
16831: =head2 Resource Information
16832: 
16833: =over 4
16834: 
16835: =item *
16836: 
16837: EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates 
16838: and returns the value of a variety of different possible values,
16839: $varname should be a request string, and the other parameters can be
16840: used to specify who and what one is asking about. Ordinarily, $cid 
16841: does not need to be specified, as it is retrived from 
16842: $env{'request.course.id'}, but &Apache::lonnet::EXT() is called
16843: within lonuserstate::loadmap() when initializing a course, before
16844: $env{'request.course.id'} has been set, so it needs to be provided
16845: in that one case.
16846: 
16847: Possible values for $varname are environment.lastname (or other item
16848: from the envirnment hash), user.name (or someother aspect about the
16849: user), resource.0.maxtries (or some other part and parameter of a
16850: resource)
16851: 
16852: =item *
16853: 
16854: directcondval($number) : get current value of a condition; reads from a state
16855: string
16856: 
16857: =item *
16858: 
16859: condval($condidx) : value of condition index based on state
16860: 
16861: =item *
16862: 
16863: metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a
16864: resource's metadata, $what should be either a specific key, or either
16865: 'keys' (to get a list of possible keys) or 'packages' to get a list of
16866: packages that this resource currently uses, the last 3 arguments are 
16867: only used internally for recursive metadata.
16868: 
16869: the toolsymb is only used where the uri is for an external tool (for which
16870: the uri as well as the symb are guaranteed to be unique).
16871: 
16872: this function automatically caches all requests except any made recursively
16873: to retrieve a list of metadata keys for an imported library file ($liburi is 
16874: defined).
16875: 
16876: =item *
16877: 
16878: metadata_query($query,$custom,$customshow) : make a metadata query against the
16879: network of library servers; returns file handle of where SQL and regex results
16880: will be stored for query
16881: 
16882: =item *
16883: 
16884: symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : 
16885: return symbolic list entry (all arguments optional). 
16886: 
16887: Args: filename is the filename (including path) for the file for which a symb 
16888: is required; donotrecurse, if true will prevent calls to allowed() being made 
16889: to check access status if more than one resource was found in the bighash 
16890: (see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of 
16891: a randompick); ignorecachednull, if true will prevent a symb of '' being 
16892: returned if $env{$cache_str} is defined as ''; checkforblock if true will
16893: cause possible symbs to be checked to determine if they are subject to content
16894: blocking, if so they will not be included as possible symbs; possibles is a
16895: ref to a hash, which, as a side effect, will be populated with all possible 
16896: symbs (content blocking not tested).
16897:  
16898: returns the data handle
16899: 
16900: =item *
16901: 
16902: symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists
16903: and is a possible symb for the URL in $thisfn, and if is an encrypted
16904: resource that the user accessed using /enc/ returns a 1 on success, 0
16905: on failure, user must be in a course, as it assumes the existence of
16906: the course initial hash, and uses $env('request.course.id'}.  The third
16907: arg is an optional reference to a scalar.  If this arg is passed in the 
16908: call to symbverify, it will be set to 1 if the symb has been set to be 
16909: encrypted; otherwise it will be null.  
16910: 
16911: =item *
16912: 
16913: symbclean($symb) : removes versions numbers from a symb, returns the
16914: cleaned symb
16915: 
16916: =item *
16917: 
16918: is_on_map($uri) : checks if the $uri is somewhere on the current
16919: course map, user must be in a course for it to work.
16920: 
16921: =item *
16922: 
16923: numval($salt) : return random seed value (addend for rndseed)
16924: 
16925: =item *
16926: 
16927: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
16928: a random seed, all arguments are optional, if they aren't sent it uses the
16929: environment to derive them. Note: if symb isn't sent and it can't get one
16930: from &symbread it will use the current time as its return value
16931: 
16932: =item *
16933: 
16934: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
16935: unfakeable, receipt
16936: 
16937: =item *
16938: 
16939: receipt() : API to ireceipt working off of env values; given out to users
16940: 
16941: =item *
16942: 
16943: countacc($url) : count the number of accesses to a given URL
16944: 
16945: =item *
16946: 
16947: 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
16948: 
16949: =item *
16950: 
16951: 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)
16952: 
16953: =item *
16954: 
16955: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
16956: 
16957: =item *
16958: 
16959: devalidate($symb) : devalidate temporary spreadsheet calculations,
16960: forcing spreadsheet to reevaluate the resource scores next time.
16961: 
16962: =item * 
16963: 
16964: can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
16965: when viewing in course context.
16966: 
16967:  input: six args -- filename (decluttered), course number, course domain,
16968:                     url, symb (if registered) and group (if this is a 
16969:                     group item -- e.g., bulletin board, group page etc.).
16970: 
16971:  output: array of five scalars --
16972:          $cfile -- url for file editing if editable on current server
16973:          $home -- homeserver of resource (i.e., for author if published,
16974:                                           or course if uploaded.).
16975:          $switchserver --  1 if server switch will be needed.
16976:          $forceedit -- 1 if icon/link should be to go to edit mode 
16977:          $forceview -- 1 if icon/link should be to go to view mode
16978: 
16979: =item *
16980: 
16981: is_course_upload($file,$cnum,$cdom)
16982: 
16983: Used in course context to determine if current file was uploaded to 
16984: the course (i.e., would be found in /userfiles/docs on the course's 
16985: homeserver.
16986: 
16987:   input: 3 args -- filename (decluttered), course number and course domain.
16988:   output: boolean -- 1 if file was uploaded.
16989: 
16990: =back
16991: 
16992: =head2 Storing/Retreiving Data
16993: 
16994: =over 4
16995: 
16996: =item *
16997: 
16998: store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash
16999: permanently for this url; hashref needs to be given and should be a \%hashname;
17000: the remaining args aren't required and if they aren't passed or are '' they will
17001: be derived from the env (with the exception of $laststore, which is an 
17002: optional arg used when a user's submission is stored in grading).
17003: $laststore is $version=$timestamp, where $version is the most recent version
17004: number retrieved for the corresponding $symb in the $namespace db file, and
17005: $timestamp is the timestamp for that transaction (UNIX time).
17006: $laststore is currently only passed when cstore() is called by 
17007: structuretags::finalize_storage().
17008: 
17009: =item *
17010: 
17011: cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store
17012: but uses critical subroutine
17013: 
17014: =item *
17015: 
17016: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
17017: all args are optional
17018: 
17019: =item *
17020: 
17021: dumpstore($namespace,$udom,$uname,$regexp,$range) : 
17022: dumps the complete (or key matching regexp) namespace into a hash
17023: ($udom, $uname, $regexp, $range are optional) for a namespace that is
17024: normally &store()ed into
17025: 
17026: $range should be either an integer '100' (give me the first 100
17027:                                            matching records)
17028:               or be  two integers sperated by a - with no spaces
17029:                  '30-50' (give me the 30th through the 50th matching
17030:                           records)
17031: 
17032: 
17033: =item *
17034: 
17035: putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :
17036: replaces a &store() version of data with a replacement set of data
17037: for a particular resource in a namespace passed in the $storehash hash 
17038: reference. If $tolog is true, the transaction is logged in the courselog
17039: with an action=PUTSTORE.
17040: 
17041: =item *
17042: 
17043: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
17044: works very similar to store/cstore, but all data is stored in a
17045: temporary location and can be reset using tmpreset, $storehash should
17046: be a hash reference, returns nothing on success
17047: 
17048: =item *
17049: 
17050: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
17051: similar to restore, but all data is stored in a temporary location and
17052: can be reset using tmpreset. Returns a hash of values on success,
17053: error string otherwise.
17054: 
17055: =item *
17056: 
17057: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
17058: deltes all keys for $symb form the temporary storage hash.
17059: 
17060: =item *
17061: 
17062: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
17063: reference filled in from namesp ($udom and $uname are optional)
17064: 
17065: =item *
17066: 
17067: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
17068: namesp ($udom and $uname are optional)
17069: 
17070: =item *
17071: 
17072: dump($namespace,$udom,$uname,$regexp,$range) : 
17073: dumps the complete (or key matching regexp) namespace into a hash
17074: ($udom, $uname, $regexp, $range are optional)
17075: 
17076: $range should be either an integer '100' (give me the first 100
17077:                                            matching records)
17078:               or be  two integers sperated by a - with no spaces
17079:                  '30-50' (give me the 30th through the 50th matching
17080:                           records)
17081: =item *
17082: 
17083: inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
17084: $store can be a scalar, an array reference, or if the amount to be 
17085: incremented is > 1, a hash reference.
17086: 
17087: ($udom and $uname are optional)
17088: 
17089: =item *
17090: 
17091: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
17092: ($udom and $uname are optional)
17093: 
17094: =item *
17095: 
17096: cput($namespace,$storehash,$udom,$uname) : critical put
17097: ($udom and $uname are optional)
17098: 
17099: =item *
17100: 
17101: newput($namespace,$storehash,$udom,$uname) :
17102: 
17103: Attempts to store the items in the $storehash, but only if they don't
17104: currently exist, if this succeeds you can be certain that you have 
17105: successfully created a new key value pair in the $namespace db.
17106: 
17107: 
17108: Args:
17109:  $namespace: name of database to store values to
17110:  $storehash: hashref to store to the db
17111:  $udom: (optional) domain of user containing the db
17112:  $uname: (optional) name of user caontaining the db
17113: 
17114: Returns:
17115:  'ok' -> succeeded in storing all keys of $storehash
17116:  'key_exists: <key>' -> failed to anything out of $storehash, as at
17117:                         least <key> already existed in the db (other
17118:                         requested keys may also already exist)
17119:  'error: <msg>' -> unable to tie the DB or other error occurred
17120:  'con_lost' -> unable to contact request server
17121:  'refused' -> action was not allowed by remote machine
17122: 
17123: 
17124: =item *
17125: 
17126: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
17127: reference filled in from namesp (encrypts the return communication)
17128: ($udom and $uname are optional)
17129: 
17130: =item *
17131: 
17132: log($udom,$name,$home,$message) : write to permanent log for user; use
17133: critical subroutine
17134: 
17135: =item *
17136: 
17137: get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
17138: array reference filled in from namespace found in domain level on either
17139: specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).
17140: 
17141: =item *
17142: 
17143: put_dom($namespace,$storehash,$udom,$uhome) :  stores hash in namespace at 
17144: domain level either on specified domain server ($uhome) or primary domain 
17145: server ($udom and $uhome are optional)
17146: 
17147: =item * 
17148: 
17149: get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults 
17150: for: authentication, language, quotas, timezone, date locale, and portal URL in
17151: the target domain.
17152: 
17153: May also include additional key => value pairs for the following groups:
17154: 
17155: =over
17156: 
17157: =item
17158: disk quotas (MB allocated by default to portfolios and authoring spaces).
17159: 
17160: =over
17161: 
17162: =item defaultquota, authorquota
17163: 
17164: =back
17165: 
17166: =item
17167: tools (availability of aboutme page, blog, webDAV access for authoring spaces,
17168: portfolio for users).
17169: 
17170: =over
17171: 
17172: =item
17173: aboutme, blog, webdav, portfolio
17174: 
17175: =back
17176: 
17177: =item
17178: requestcourses: ability to request courses, and how requests are processed.
17179: 
17180: =over
17181: 
17182: =item
17183: official, unofficial, community, textbook, placement
17184: 
17185: =back
17186: 
17187: =item
17188: inststatus: types of institutional affiliation, and order in which they are displayed.
17189: 
17190: =over
17191: 
17192: =item
17193: inststatustypes, inststatusorder, inststatusguest
17194: 
17195: =back
17196: 
17197: =item
17198: coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
17199: for course's uploaded content.
17200: 
17201: =over
17202: 
17203: =item
17204: canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, 
17205: communityquota, textbookquota, placementquota
17206: 
17207: =back
17208: 
17209: =item
17210: usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
17211: on your servers.
17212: 
17213: =over
17214: 
17215: =item 
17216: remotesessions, hostedsessions
17217: 
17218: =back
17219: 
17220: =back
17221: 
17222: In cases where a domain coordinator has never used the "Set Domain Configuration"
17223: utility to create a configuration.db file on a domain's primary library server 
17224: only the following domain defaults: auth_def, auth_arg_def, lang_def
17225: -- corresponding values are authentication type (internal, krb4, krb5,
17226: or localauth), initial password or a kerberos realm, language (e.g., en-us) -- 
17227: will be available. Values are retrieved from cache (if current), unless the
17228: optional $ignore_cache arg is true, or from domain's configuration.db (if available),
17229: or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
17230: 
17231: Typical usage:
17232: 
17233: %domdefaults = &get_domain_defaults($target_domain);
17234: 
17235: =back
17236: 
17237: =head2 Network Status Functions
17238: 
17239: =over 4
17240: 
17241: =item *
17242: 
17243: dirlist() : return directory list based on URI (first arg).
17244: 
17245: Inputs: 1 required, 5 optional.
17246: 
17247: =over
17248: 
17249: =item 
17250: $uri - path to file in filesystem (starts: /res or /userfiles/). Required.
17251: 
17252: =item
17253: $userdomain - domain of user/course to be listed. Extracted from $uri if absent. 
17254: 
17255: =item
17256: $username -  username of user/course to be listed. Extracted from $uri if absent. 
17257: 
17258: =item
17259: $getpropath - boolean: 1 if prepend path using &propath(). 
17260: 
17261: =item
17262: $getuserdir - boolean: 1 if prepend path for "userfiles".
17263: 
17264: =item 
17265: $alternateRoot - path to prepend in place of path from $uri.
17266: 
17267: =back
17268: 
17269: Returns: Array of up to two items.
17270: 
17271: =over
17272: 
17273: a reference to an array of files/subdirectories
17274: 
17275: =over
17276: 
17277: Each element in the array of files/subdirectories is a & separated list of
17278: item name and the result of running stat on the item.  If dirlist was requested
17279: for a file instead of a directory, the item name will be ''. For a directory 
17280: listing, if the item is a metadata file, the element will end &N&M 
17281: (where N amd M are either 0 or 1, corresponding to obsolete set (1), or
17282: default copyright set (1).  
17283: 
17284: =back
17285: 
17286: a scalar containing error condition (if encountered).
17287: 
17288: =over
17289: 
17290: =item 
17291: no_host (no homeserver identified for $username:$domain).
17292: 
17293: =item 
17294: no_such_host (server contacted for listing not identified as valid host).
17295: 
17296: =item 
17297: con_lost (connection to remote server failed).
17298: 
17299: =item 
17300: refused (invalid $username:$domain received on lond side).
17301: 
17302: =item 
17303: no_such_dir (directory at specified path on lond side does not exist). 
17304: 
17305: =item 
17306: empty (directory at specified path on lond side is empty).
17307: 
17308: =over
17309: 
17310: This is currently not encountered because the &ls3, &ls2, 
17311: &ls (_handler) routines on the lond side do not filter out
17312: . and .. from a directory listing. 
17313: 
17314: =back
17315: 
17316: =back
17317: 
17318: =back
17319: 
17320: =item *
17321: 
17322: spareserver() : find server with least workload from spare.tab
17323: 
17324: 
17325: =item *
17326: 
17327: host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
17328: if there is no corresponding loncapa host.
17329: 
17330: =back
17331: 
17332: 
17333: =head2 Apache Request
17334: 
17335: =over 4
17336: 
17337: =item *
17338: 
17339: ssi($url,%hash) : server side include, does a complete request cycle on url to
17340: localhost, posts hash
17341: 
17342: =back
17343: 
17344: =head2 Data to String to Data
17345: 
17346: =over 4
17347: 
17348: =item *
17349: 
17350: hash2str(%hash) : convert a hash into a string complete with escaping and '='
17351: and '&' separators, supports elements that are arrayrefs and hashrefs
17352: 
17353: =item *
17354: 
17355: hashref2str($hashref) : convert a hashref into a string complete with
17356: escaping and '=' and '&' separators, supports elements that are
17357: arrayrefs and hashrefs
17358: 
17359: =item *
17360: 
17361: arrayref2str($arrayref) : convert an arrayref into a string complete
17362: with escaping and '&' separators, supports elements that are arrayrefs
17363: and hashrefs
17364: 
17365: =item *
17366: 
17367: str2hash($string) : convert string to hash using unescaping and
17368: splitting on '=' and '&', supports elements that are arrayrefs and
17369: hashrefs
17370: 
17371: =item *
17372: 
17373: str2array($string) : convert string to hash using unescaping and
17374: splitting on '&', supports elements that are arrayrefs and hashrefs
17375: 
17376: =back
17377: 
17378: =head2 Logging Routines
17379: 
17380: 
17381: These routines allow one to make log messages in the lonnet.log and
17382: lonnet.perm logfiles.
17383: 
17384: =over 4
17385: 
17386: =item *
17387: 
17388: logtouch() : make sure the logfile, lonnet.log, exists
17389: 
17390: =item *
17391: 
17392: logthis() : append message to the normal lonnet.log file, it gets
17393: preiodically rolled over and deleted.
17394: 
17395: =item *
17396: 
17397: logperm() : append a permanent message to lonnet.perm.log, this log
17398: file never gets deleted by any automated portion of the system, only
17399: messages of critical importance should go in here.
17400: 
17401: 
17402: =back
17403: 
17404: =head2 General File Helper Routines
17405: 
17406: =over 4
17407: 
17408: =item *
17409: 
17410: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
17411: (a) files in /uploaded
17412:   (i) If a local copy of the file exists - 
17413:       compares modification date of local copy with last-modified date for 
17414:       definitive version stored on home server for course. If local copy is 
17415:       stale, requests a new version from the home server and stores it. 
17416:       If the original has been removed from the home server, then local copy 
17417:       is unlinked.
17418:   (ii) If local copy does not exist -
17419:       requests the file from the home server and stores it. 
17420:   
17421:   If $caller is 'uploadrep':  
17422:     This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
17423:     for request for files originally uploaded via DOCS. 
17424:      - returns 'ok' if fresh local copy now available, -1 otherwise.
17425:   
17426:   Otherwise:
17427:      This indicates a call from the content generation phase of the request.
17428:      -  returns the entire contents of the file or -1.
17429:      
17430: (b) files in /res
17431:    - returns the entire contents of a file or -1; 
17432:    it properly subscribes to and replicates the file if neccessary.
17433: 
17434: 
17435: =item *
17436: 
17437: stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
17438:                   reference
17439: 
17440: returns either a stat() list of data about the file or an empty list
17441: if the file doesn't exist or couldn't find out about it (connection
17442: problems or user unknown)
17443: 
17444: =item *
17445: 
17446: filelocation($dir,$file) : returns file system location of a file
17447: based on URI; meant to be "fairly clean" absolute reference, $dir is a
17448: directory that relative $file lookups are to looked in ($dir of /a/dir
17449: and a file of ../bob will become /a/bob)
17450: 
17451: =item *
17452: 
17453: hreflocation($dir,$file) : returns file system location or a URL; same as
17454: filelocation except for hrefs
17455: 
17456: =item *
17457: 
17458: declutter() : declutters URLs -- remove beginning slashes, 'res' etc.
17459: also removes beginning /home/httpd/html unless /priv/ follows it.
17460: 
17461: =back
17462: 
17463: =head2 Usererfile file routines (/uploaded*)
17464: 
17465: =over 4
17466: 
17467: =item *
17468: 
17469: userfileupload(): main rotine for putting a file in a user or course's
17470:                   filespace, arguments are,
17471: 
17472:  formname - required - this is the name of the element in $env where the
17473:            filename, and the contents of the file to create/modifed exist
17474:            the filename is in $env{'form.'.$formname.'.filename'} and the
17475:            contents of the file is located in $env{'form.'.$formname}
17476:  context - if coursedoc, store the file in the course of the active role
17477:              of the current user; 
17478:            if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp
17479:            if 'canceloverwrite': delete file in tmp/overwrites directory
17480:  subdir - required - subdirectory to put the file in under ../userfiles/
17481:          if undefined, it will be placed in "unknown"
17482: 
17483:  (This routine calls clean_filename() to remove any dangerous
17484:  characters from the filename, and then calls finuserfileupload() to
17485:  complete the transaction)
17486: 
17487:  returns either the url of the uploaded file (/uploaded/....) if successful
17488:  and /adm/notfound.html if unsuccessful
17489: 
17490: =item *
17491: 
17492: clean_filename(): routine for cleaing a filename up for storage in
17493:                  userfile space, argument is:
17494: 
17495:  filename - proposed filename
17496: 
17497: returns: the new clean filename
17498: 
17499: =item *
17500: 
17501: finishuserfileupload(): routine that creates and sends the file to
17502: userspace, probably shouldn't be called directly
17503: 
17504:   docuname: username or courseid of destination for the file
17505:   docudom: domain of user/course of destination for the file
17506:   formname: same as for userfileupload()
17507:   fname: filename (including subdirectories) for the file
17508:   parser: if 'parse', will parse (html) file to extract references to objects, links etc.
17509:           if hashref, and context is scantron, will convert csv format to standard format
17510:   allfiles: reference to hash used to store objects found by parser
17511:   codebase: reference to hash used for codebases of java objects found by parser
17512:   thumbwidth: width (pixels) of thumbnail to be created for uploaded image
17513:   thumbheight: height (pixels) of thumbnail to be created for uploaded image
17514:   resizewidth: width to be used to resize image using resizeImage from ImageMagick
17515:   resizeheight: height to be used to resize image using resizeImage from ImageMagick
17516:   context: if 'overwrite', will move the uploaded file from its temporary location to
17517:             userfiles to facilitate overwriting a previously uploaded file with same name.
17518:   mimetype: reference to scalar to accommodate mime type determined
17519:             from File::MMagic if $parser = parse.
17520: 
17521:  returns either the url of the uploaded file (/uploaded/....) if successful
17522:  and /adm/notfound.html if unsuccessful (or an error message if context 
17523:  was 'overwrite').
17524:  
17525: 
17526: =item *
17527: 
17528: renameuserfile(): renames an existing userfile to a new name
17529: 
17530:   Args:
17531:    docuname: username or courseid of destination for the file
17532:    docudom: domain of user/course of destination for the file
17533:    old: current file name (including any subdirs under userfiles)
17534:    new: desired file name (including any subdirs under userfiles)
17535: 
17536: =item *
17537: 
17538: mkdiruserfile(): creates a directory is a userfiles dir
17539: 
17540:   Args:
17541:    docuname: username or courseid of destination for the file
17542:    docudom: domain of user/course of destination for the file
17543:    dir: dir to create (including any subdirs under userfiles)
17544: 
17545: =item *
17546: 
17547: removeuserfile(): removes a file that exists in userfiles
17548: 
17549:   Args:
17550:    docuname: username or courseid of destination for the file
17551:    docudom: domain of user/course of destination for the file
17552:    fname: filname to delete (including any subdirs under userfiles)
17553: 
17554: =item *
17555: 
17556: removeuploadedurl(): convience function for removeuserfile()
17557: 
17558:   Args:
17559:    url:  a full /uploaded/... url to delete
17560: 
17561: =item * 
17562: 
17563: get_portfile_permissions():
17564:   Args:
17565:     domain: domain of user or course contain the portfolio files
17566:     user: name of user or num of course contain the portfolio files
17567:   Returns:
17568:     hashref of a dump of the proper file_permissions.db
17569:    
17570: 
17571: =item * 
17572: 
17573: get_access_controls():
17574: 
17575: Args:
17576:   current_permissions: the hash ref returned from get_portfile_permissions()
17577:   group: (optional) the group you want the files associated with
17578:   file: (optional) the file you want access info on
17579: 
17580: Returns:
17581:     a hash (keys are file names) of hashes containing
17582:         keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
17583:         values are XML containing access control settings (see below) 
17584: 
17585: Internal notes:
17586: 
17587:  access controls are stored in file_permissions.db as key=value pairs.
17588:     key -> path to file/file_name\0uniqueID:scope_end_start
17589:         where scope -> public,guest,course,group,domains or users.
17590:               end -> UNIX time for end of access (0 -> no end date)
17591:               start -> UNIX time for start of access
17592: 
17593:     value -> XML description of access control
17594:            <scope type=""> (type =1 of: public,guest,course,group,domains,users">
17595:             <start></start>
17596:             <end></end>
17597: 
17598:             <password></password>  for scope type = guest
17599: 
17600:             <domain></domain>     for scope type = course or group
17601:             <number></number>
17602:             <roles id="">
17603:              <role></role>
17604:              <access></access>
17605:              <section></section>
17606:              <group></group>
17607:             </roles>
17608: 
17609:             <dom></dom>         for scope type = domains
17610: 
17611:             <users>             for scope type = users
17612:              <user>
17613:               <uname></uname>
17614:               <udom></udom>
17615:              </user>
17616:             </users>
17617:            </scope> 
17618:               
17619:  Access data is also aggregated for each file in an additional key=value pair:
17620:  key -> path to file/file_name\0accesscontrol 
17621:  value -> reference to hash
17622:           hash contains key = value pairs
17623:           where key = uniqueID:scope_end_start
17624:                 value = UNIX time record was last updated
17625: 
17626:           Used to improve speed of look-ups of access controls for each file.  
17627:  
17628:  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
17629: 
17630: =item *
17631: 
17632: modify_access_controls():
17633: 
17634: Modifies access controls for a portfolio file
17635: Args
17636: 1. file name
17637: 2. reference to hash of required changes,
17638: 3. domain
17639: 4. username
17640:   where domain,username are the domain of the portfolio owner 
17641:   (either a user or a course) 
17642: 
17643: Returns:
17644: 1. result of additions or updates ('ok' or 'error', with error message). 
17645: 2. result of deletions ('ok' or 'error', with error message).
17646: 3. reference to hash of any new or updated access controls.
17647: 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
17648:    key = integer (inbound ID)
17649:    value = uniqueID
17650: 
17651: =item *
17652: 
17653: get_timebased_id():
17654: 
17655: Attempts to get a unique timestamp-based suffix for use with items added to a 
17656: course via the Course Editor (e.g., folders, composite pages, 
17657: group bulletin boards).
17658: 
17659: Args: (first three required; six others optional)
17660: 
17661: 1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage,
17662:    docssequence, or name of group
17663: 
17664: 2. keyid (alphanumeric): name of temporary locking key in hash,
17665:    e.g., num, boardids
17666: 
17667: 3. namespace: name of gdbm file used to store suffixes already assigned;  
17668:    file will be named nohist_namespace.db
17669: 
17670: 4. cdom: domain of course; default is current course domain from %env
17671: 
17672: 5. cnum: course number; default is current course number from %env
17673: 
17674: 6. idtype: set to concat if an additional digit is to be appended to the 
17675:    unix timestamp to form the suffix, if the plain timestamp is already
17676:    in use.  Default is to not do this, but simply increment the unix 
17677:    timestamp by 1 until a unique key is obtained.
17678: 
17679: 7. who: holder of locking key; defaults to user:domain for user.
17680: 
17681: 8. locktries: number of attempts to obtain a lock (sleep of 1s before 
17682:    retrying); default is 3.
17683: 
17684: 9. maxtries: number of attempts to obtain a unique suffix; default is 20.  
17685: 
17686: Returns:
17687: 
17688: 1. suffix obtained (numeric)
17689: 
17690: 2. result of deleting locking key (ok if deleted, or lock never obtained)
17691: 
17692: 3. error: contains (localized) error message if an error occurred.
17693: 
17694: 
17695: =back
17696: 
17697: =head2 HTTP Helper Routines
17698: 
17699: =over 4
17700: 
17701: =item *
17702: 
17703: escape() : unpack non-word characters into CGI-compatible hex codes
17704: 
17705: =item *
17706: 
17707: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
17708: 
17709: =back
17710: 
17711: =head1 PRIVATE SUBROUTINES
17712: 
17713: =head2 Underlying communication routines (Shouldn't call)
17714: 
17715: =over 4
17716: 
17717: =item *
17718: 
17719: subreply() : tries to pass a message to lonc, returns con_lost if incapable
17720: 
17721: =item *
17722: 
17723: reply() : uses subreply to send a message to remote machine, logs all failures
17724: 
17725: =item *
17726: 
17727: critical() : passes a critical message to another server; if cannot
17728: get through then place message in connection buffer directory and
17729: returns con_delayed, if incapable of saving message, returns
17730: con_failed
17731: 
17732: =item *
17733: 
17734: reconlonc() : tries to reconnect lonc client processes.
17735: 
17736: =back
17737: 
17738: =head2 Resource Access Logging
17739: 
17740: =over 4
17741: 
17742: =item *
17743: 
17744: flushcourselogs() : flush (save) buffer logs and access logs
17745: 
17746: =item *
17747: 
17748: courselog($what) : save message for course in hash
17749: 
17750: =item *
17751: 
17752: courseacclog($what) : save message for course using &courselog().  Perform
17753: special processing for specific resource types (problems, exams, quizzes, etc).
17754: 
17755: =item *
17756: 
17757: goodbye() : flush course logs and log shutting down; it is called in srm.conf
17758: as a PerlChildExitHandler
17759: 
17760: =back
17761: 
17762: =head2 Other
17763: 
17764: =over 4
17765: 
17766: =item *
17767: 
17768: symblist($mapname,%newhash) : update symbolic storage links
17769: 
17770: =back
17771: 
17772: =cut
17773: 

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