loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.881 and 1.993

version 1.881, 2007/05/26 00:38:19	version 1.993, 2009/04/11 14:47:51
Line 27	Line 27
#	#
###	###

	=pod

	=head1 NAME

	Apache::lonnet.pm

	=head1 SYNOPSIS

	This file is an interface to the lonc processes of
	the LON-CAPA network as well as set of elaborated functions for handling information
	necessary for navigating through a given cluster of LON-CAPA machines within a
	domain. There are over 40 specialized functions in this module which handle the
	reading and transmission of metadata, user information (ids, names, environments, roles,
	logs), file information (storage, reading, directories, extensions, replication, embedded
	styles and descriptors), educational resources (course descriptions, section names and
	numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
	and from more descriptive phrases or explanations.

	This is part of the LearningOnline Network with CAPA project
	described at http://www.lon-capa.org.

	=head1 Package Variables

	These are largely undocumented, so if you decipher one please note it here.

	=over 4

	=item $processmarker

	Contains the time this process was started and this servers host id.

	=item $dumpcount

	Counts the number of times a message log flush has been attempted (regardless
	of success) by this process. Used as part of the filename when messages are
	delayed.

	=back

	=cut

package Apache::lonnet;	package Apache::lonnet;

use strict;	use strict;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	use Image::Magick;

use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir	use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env);	$_64bit %env %protocol);

my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,	my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,	%userrolehash, $processmarker, $dumpcount, %coursedombuf,
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,	%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
%courseownerbuf, %coursetypebuf);	%courseownerbuf, %coursetypebuf,$locknum);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
Line 56 use LONCAPA::Configuration;	Line 98 use LONCAPA::Configuration;
my $readit;	my $readit;
my $max_connection_retries = 10; # Or some such value.	my $max_connection_retries = 10; # Or some such value.

	my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true

require Exporter;	require Exporter;

our @ISA = qw (Exporter);	our @ISA = qw (Exporter);
our @EXPORT = qw(%env);	our @EXPORT = qw(%env);

=pod

=head1 Package Variables

These are largely undocumented, so if you decipher one please note it here.

=over 4

=item $processmarker

Contains the time this process was started and this servers host id.

=item $dumpcount

Counts the number of times a message log flush has been attempted (regardless
of success) by this process. Used as part of the filename when messages are
delayed.

=back

=cut


# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
{	{
my $logid;	my $logid;
sub instructor_log {	sub instructor_log {
my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;	my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
	if (($cnum eq '') \|\| ($cdom eq '')) {
	$cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	}
$logid++;	$logid++;
my $id=time().'00000'.$$.'00000'.$logid;	my $now = time();
	my $id=$now.'00000'.$$.'00000'.$logid;
return &Apache::lonnet::put('nohist_'.$hash_name,	return &Apache::lonnet::put('nohist_'.$hash_name,
{ $id => {	{ $id => {
'exe_uname' => $env{'user.name'},	'exe_uname' => $env{'user.name'},
'exe_udom' => $env{'user.domain'},	'exe_udom' => $env{'user.domain'},
'exe_time' => time(),	'exe_time' => $now,
'exe_ip' => $ENV{'REMOTE_ADDR'},	'exe_ip' => $ENV{'REMOTE_ADDR'},
'delflag' => $delflag,	'delflag' => $delflag,
'logentry' => $storehash,	'logentry' => $storehash,
'uname' => $uname,	'uname' => $uname,
'udom' => $udom,	'udom' => $udom,
}	}
},	},$cdom,$cnum);
$env{'course.'.$env{'request.course.id'}.'.domain'},
$env{'course.'.$env{'request.course.id'}.'.num'}
);
}	}
}	}

Line 125 sub logthis {	Line 149 sub logthis {
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
if (open(my $fh,">>$execdir/logs/lonnet.log")) {	if (open(my $fh,">>$execdir/logs/lonnet.log")) {
print $fh "$local ($$): $message\n";	my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
	print $fh $logstring;
close($fh);	close($fh);
}	}
return 1;	return 1;
Line 149 sub create_connection {	Line 174 sub create_connection {
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10);	Timeout => 10);
return 0 if (!$client);	return 0 if (!$client);
print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");	print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
my $result = <$client>;	my $result = <$client>;
chomp($result);	chomp($result);
return 1 if ($result eq 'done');	return 1 if ($result eq 'done');
return 0;	return 0;
}	}

	sub get_server_timezone {
	my ($cnum,$cdom) = @_;
	my $home=&homeserver($cnum,$cdom);
	if ($home ne 'no_host') {
	my $cachetime = 24*3600;
	my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
	if (defined($cached)) {
	return $timezone;
	} else {
	my $timezone = &reply('servertimezone',$home);
	return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
	}
	}
	}

	sub get_server_loncaparev {
	my ($dom,$lonhost) = @_;
	if (defined($lonhost)) {
	if (!defined(&hostname($lonhost))) {
	undef($lonhost);
	}
	}
	if (!defined($lonhost)) {
	if (defined(&domain($dom,'primary'))) {
	$lonhost=&domain($dom,'primary');
	if ($lonhost eq 'no_host') {
	undef($lonhost);
	}
	}
	}
	if (defined($lonhost)) {
	my $cachetime = 24*3600;
	my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
	if (defined($cached)) {
	return $loncaparev;
	} else {
	my $loncaparev = &reply('serverloncaparev',$lonhost);
	return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
	}
	}
	}

# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
Line 214 sub reply {	Line 280 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {	sub reconlonc {
	my ($lonid) = @_;
	my $hostname = &hostname($lonid);
	if ($lonid) {
	my $peerfile="$perlvar{'lonSockDir'}/$hostname";
	if ($hostname && -e $peerfile) {
	&logthis("Trying to reconnect lonc for $lonid ($hostname)");
	my $client=IO::Socket::UNIX->new(Peer => $peerfile,
	Type => SOCK_STREAM,
	Timeout => 10);
	if ($client) {
	print $client ("reset_retries\n");
	my $answer=<$client>;
	#reset just this one.
	}
	}
	return;
	}

&logthis("Trying to reconnect lonc");	&logthis("Trying to reconnect lonc");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {	if (open(my $fh,"<$loncfile")) {
Line 302 sub convert_and_load_session_env {	Line 386 sub convert_and_load_session_env {
my ($lonidsdir,$handle)=@_;	my ($lonidsdir,$handle)=@_;
my @profile;	my @profile;
{	{
open(my $idf,"$lonidsdir/$handle.id");	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
	if (!$opened) {
	return 0;
	}
flock($idf,LOCK_SH);	flock($idf,LOCK_SH);
@profile=<$idf>;	@profile=<$idf>;
close($idf);	close($idf);
Line 341 sub transfer_profile_to_env {	Line 428 sub transfer_profile_to_env {

my $convert;	my $convert;
{	{
open(my $idf,"$lonidsdir/$handle.id");	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
	if (!$opened) {
	return;
	}
flock($idf,LOCK_SH);	flock($idf,LOCK_SH);
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
Line 373 sub transfer_profile_to_env {	Line 463 sub transfer_profile_to_env {
}	}
}	}

	# ---------------------------------------------------- Check for valid session
	sub check_for_valid_session {
	my ($r) = @_;
	my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
	my $lonid=$cookies{'lonID'};
	return undef if (!$lonid);

	my $handle=&LONCAPA::clean_handle($lonid->value);
	my $lonidsdir=$r->dir_config('lonIDsDir');
	return undef if (!-e "$lonidsdir/$handle.id");

	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
	return undef if (!$opened);

	flock($idf,LOCK_SH);
	my %disk_env;
	if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
	&GDBM_READER(),0640)) {
	return undef;
	}

	if (!defined($disk_env{'user.name'})
	\|\| !defined($disk_env{'user.domain'})) {
	return undef;
	}
	return $handle;
	}

sub timed_flock {	sub timed_flock {
my ($file,$lock_type) = @_;	my ($file,$lock_type) = @_;
my $failed=0;	my $failed=0;
Line 396 sub timed_flock {	Line 514 sub timed_flock {
# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment

sub appenv {	sub appenv {
my %newenv=@_;	my ($newenv,$roles) = @_;
foreach my $key (keys(%newenv)) {	if (ref($newenv) eq 'HASH') {
if (($newenv{$key}=~/^user\.role/) \|\| ($newenv{$key}=~/^user\.priv/)) {	foreach my $key (keys(%{$newenv})) {
&logthis("<font color=\"blue\">WARNING: ".	my $refused = 0;
"Attempt to modify environment ".$key." to ".$newenv{$key}	if (($key =~ /^user\.role/) \|\| ($key =~ /^user\.priv/)) {
.'</font>');	$refused = 1;
delete($newenv{$key});	if (ref($roles) eq 'ARRAY') {
} else {	my ($type,$role) = ($key =~ /^user\.(role\|priv)\.([^.]+)\./);
$env{$key}=$newenv{$key};	if (grep(/^\Q$role\E$/,@{$roles})) {
	$refused = 0;
	}
	}
	}
	if ($refused) {
	&logthis("<font color=\"blue\">WARNING: ".
	"Attempt to modify environment ".$key." to ".$newenv->{$key}
	.'</font>');
	delete($newenv->{$key});
	} else {
	$env{$key}=$newenv->{$key};
	}
	}
	my $opened = open(my $env_file,'+<',$env{'user.environment'});
	if ($opened
	&& &timed_flock($env_file,LOCK_EX)
	&&
	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
	while (my ($key,$value) = each(%{$newenv})) {
	$disk_env{$key} = $value;
	}
	untie(%disk_env);
}	}
}
open(my $env_file,$env{'user.environment'});
if (&timed_flock($env_file,LOCK_EX)
&&
tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
while (my ($key,$value) = each(%newenv)) {
$disk_env{$key} = $value;
}
untie(%disk_env);
}	}
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment

sub delenv {	sub delenv {
my $delthis=shift;	my ($delthis,$regexp) = @_;
if (($delthis=~/user\.role/) \|\| ($delthis=~/user\.priv/)) {	if (($delthis=~/user\.role/) \|\| ($delthis=~/user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);	"Attempt to delete from environment ".$delthis);
return 'error';	return 'error';
}	}
open(my $env_file,$env{'user.environment'});	my $opened = open(my $env_file,'+<',$env{'user.environment'});
if (&timed_flock($env_file,LOCK_EX)	if ($opened
	&& &timed_flock($env_file,LOCK_EX)
&&	&&
tie(my %disk_env,'GDBM_File',$env{'user.environment'},	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
foreach my $key (keys(%disk_env)) {	foreach my $key (keys(%disk_env)) {
if ($key=~/^$delthis/) {	if ($regexp) {
delete($env{$key});	if ($key=~/^$delthis/) {
delete($disk_env{$key});	delete($env{$key});
	delete($disk_env{$key});
	}
	} else {
	if ($key=~/^\Q$delthis\E/) {
	delete($env{$key});
	delete($disk_env{$key});
	}
}	}
}	}
untie(%disk_env);	untie(%disk_env);
Line 458 sub get_env_multiple {	Line 597 sub get_env_multiple {
return(@values);	return(@values);
}	}

	# ------------------------------------------------------------------- Locking

	sub set_lock {
	my ($text)=@_;
	$locknum++;
	my $id=$$.'-'.$locknum;
	&appenv({'session.locks' => $env{'session.locks'}.','.$id,
	'session.lock.'.$id => $text});
	return $id;
	}

	sub get_locks {
	my $num=0;
	my %texts=();
	foreach my $lock (split(/\,/,$env{'session.locks'})) {
	if ($lock=~/\w/) {
	$num++;
	$texts{$lock}=$env{'session.lock.'.$lock};
	}
	}
	return ($num,%texts);
	}

	sub remove_lock {
	my ($id)=@_;
	my $newlocks='';
	foreach my $lock (split(/\,/,$env{'session.locks'})) {
	if (($lock=~/\w/) && ($lock ne $id)) {
	$newlocks.=','.$lock;
	}
	}
	&appenv({'session.locks' => $newlocks});
	&delenv('session.lock.'.$id);
	}

	sub remove_all_locks {
	my $activelocks=$env{'session.locks'};
	foreach my $lock (split(/\,/,$env{'session.locks'})) {
	if ($lock=~/\w/) {
	&remove_lock($lock);
	}
	}
	}


# ------------------------------------------ Find out current server userload	# ------------------------------------------ Find out current server userload
# there is a copy in lond
sub userload {	sub userload {
my $numusers=0;	my $numusers=0;
{	{
Line 467 sub userload {	Line 650 sub userload {
my $filename;	my $filename;
my $curtime=time;	my $curtime=time;
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	next if ($filename eq '.' \|\| $filename eq '..');
	next if ($filename =~ /publicuser_\d+\.id/);
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
Line 530 sub spareserver {	Line 714 sub spareserver {
}	}

if (!$want_server_name) {	if (!$want_server_name) {
$spare_server="http://".&hostname($spare_server);	my $protocol = 'http';
	if ($protocol{$spare_server} eq 'https') {
	$protocol = $protocol{$spare_server};
	}
	$spare_server = $protocol.'://'.&hostname($spare_server);
}	}
return $spare_server;	return $spare_server;
}	}
Line 564 sub compare_server_load {	Line 752 sub compare_server_load {
}	}
return ($spare_server,$lowest_load);	return ($spare_server,$lowest_load);
}	}

	# --------------------------- ask offload servers if user already has a session
	sub find_existing_session {
	my ($udom,$uname) = @_;
	foreach my $try_server (@{ $spareid{'primary'} },
	@{ $spareid{'default'} }) {
	return $try_server if (&has_user_session($try_server, $udom, $uname));
	}
	return;
	}

	# -------------------------------- ask if server already has a session for user
	sub has_user_session {
	my ($lonid,$udom,$uname) = @_;
	my $result = &reply(join(':','userhassession',
	map {&escape($_)} ($udom,$uname)),$lonid);
	return 1 if ($result eq 'ok');

	return 0;
	}

# --------------------------------------------- Try to change a user's password	# --------------------------------------------- Try to change a user's password

sub changepass {	sub changepass {
Line 618 sub queryauthenticate {	Line 827 sub queryauthenticate {
# --------- Try to authenticate user from domain's lib servers (first this one)	# --------- Try to authenticate user from domain's lib servers (first this one)

sub authenticate {	sub authenticate {
my ($uname,$upass,$udom)=@_;	my ($uname,$upass,$udom,$checkdefauth)=@_;
$upass=&escape($upass);	$upass=&escape($upass);
$uname= &LONCAPA::clean_username($uname);	$uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom,1);	my $uhome=&homeserver($uname,$udom,1);
	my $newhome;
if ((!$uhome) \|\| ($uhome eq 'no_host')) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
# Maybe the machine was offline and only re-appeared again recently?	# Maybe the machine was offline and only re-appeared again recently?
&reconlonc();	&reconlonc();
# One more	# One more
my $uhome=&homeserver($uname,$udom,1);	$uhome=&homeserver($uname,$udom,1);
	if (($uhome eq 'no_host') && $checkdefauth) {
	if (defined(&domain($udom,'primary'))) {
	$newhome=&domain($udom,'primary');
	}
	if ($newhome ne '') {
	$uhome = $newhome;
	}
	}
if ((!$uhome) \|\| ($uhome eq 'no_host')) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown in authenticate");	&logthis("User $uname at $udom is unknown in authenticate");
}	return 'no_host';
return 'no_host';	}
}	}
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);	my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
if ($answer eq 'authorized') {	if ($answer eq 'authorized') {
&logthis("User $uname at $udom authorized by $uhome");	if ($newhome) {
return $uhome;	&logthis("User $uname at $udom authorized by $uhome, but needs account");
	return 'no_account_on_host';
	} else {
	&logthis("User $uname at $udom authorized by $uhome");
	return $uhome;
	}
}	}
if ($answer eq 'non_authorized') {	if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $uhome");	&logthis("User $uname at $udom rejected by $uhome");
Line 807 sub put_dom {	Line 1030 sub put_dom {
sub retrieve_inst_usertypes {	sub retrieve_inst_usertypes {
my ($udom) = @_;	my ($udom) = @_;
my (%returnhash,@order);	my (%returnhash,@order);
if (defined(&domain($udom,'primary'))) {	my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
my $uhome=&domain($udom,'primary');	if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
my $rep=&reply("inst_usertypes:$udom",$uhome);	(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
my ($hashitems,$orderitems) = split(/:/,$rep);	%returnhash = %{$domdefs{'inststatustypes'}};
my @pairs=split(/\&/,$hashitems);	@order = @{$domdefs{'inststatusorder'}};
foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$item,2);
$key = &unescape($key);
next if ($key =~ /^error: 2 /);
$returnhash{$key}=&thaw_unescape($value);
}
my @esc_order = split(/\&/,$orderitems);
foreach my $item (@esc_order) {
push(@order,&unescape($item));
}
} else {	} else {
&logthis("get_dom failed - no primary domain server for $udom");	if (defined(&domain($udom,'primary'))) {
	my $uhome=&domain($udom,'primary');
	my $rep=&reply("inst_usertypes:$udom",$uhome);
	if ($rep =~ /^(con_lost\|error\|no_such_host\|refused)/) {
	&logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
	return (\%returnhash,\@order);
	}
	my ($hashitems,$orderitems) = split(/:/,$rep);
	my @pairs=split(/\&/,$hashitems);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
	my @esc_order = split(/\&/,$orderitems);
	foreach my $item (@esc_order) {
	push(@order,&unescape($item));
	}
	} else {
	&logthis("get_dom failed - no primary domain server for $udom");
	}
}	}
return (\%returnhash,\@order);	return (\%returnhash,\@order);
}	}
Line 838 sub is_domainimage {	Line 1072 sub is_domainimage {
return;	return;
}	}

	sub inst_directory_query {
	my ($srch) = @_;
	my $udom = $srch->{'srchdomain'};
	my %results;
	my $homeserver = &domain($udom,'primary');
	my $outcome;
	if ($homeserver ne '') {
	my $queryid=&reply("querysend:instdirsearch:".
	&escape($srch->{'srchby'}).':'.
	&escape($srch->{'srchterm'}).':'.
	&escape($srch->{'srchtype'}),$homeserver);
	my $host=&hostname($homeserver);
	if ($queryid !~/^\Q$host\E\_/) {
	&logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
	return;
	}
	my $response = &get_query_reply($queryid);
	my $maxtries = 5;
	my $tries = 1;
	while (($response=~/^timeout/) && ($tries < $maxtries)) {
	$response = &get_query_reply($queryid);
	$tries ++;
	}

	if (!&error($response) && $response ne 'refused') {
	if ($response eq 'unavailable') {
	$outcome = $response;
	} else {
	$outcome = 'ok';
	my @matches = split(/\n/,$response);
	foreach my $match (@matches) {
	my ($key,$value) = split(/=/,$match);
	$results{&unescape($key).':'.$udom} = &thaw_unescape($value);
	}
	}
	}
	}
	return ($outcome,%results);
	}

	sub usersearch {
	my ($srch) = @_;
	my $dom = $srch->{'srchdomain'};
	my %results;
	my %libserv = &all_library();
	my $query = 'usersearch';
	foreach my $tryserver (keys(%libserv)) {
	if (&host_domain($tryserver) eq $dom) {
	my $host=&hostname($tryserver);
	my $queryid=
	&reply("querysend:".&escape($query).':'.
	&escape($srch->{'srchby'}).':'.
	&escape($srch->{'srchtype'}).':'.
	&escape($srch->{'srchterm'}),$tryserver);
	if ($queryid !~/^\Q$host\E\_/) {
	&logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
	next;
	}
	my $reply = &get_query_reply($queryid);
	my $maxtries = 1;
	my $tries = 1;
	while (($reply=~/^timeout/) && ($tries < $maxtries)) {
	$reply = &get_query_reply($queryid);
	$tries ++;
	}
	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
	&logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries);
	} else {
	my @matches;
	if ($reply =~ /\n/) {
	@matches = split(/\n/,$reply);
	} else {
	@matches = split(/\&/,$reply);
	}
	foreach my $match (@matches) {
	my ($uname,$udom,%userhash);
	foreach my $entry (split(/:/,$match)) {
	my ($key,$value) =
	map {&unescape($_);} split(/=/,$entry);
	$userhash{$key} = $value;
	if ($key eq 'username') {
	$uname = $value;
	} elsif ($key eq 'domain') {
	$udom = $value;
	}
	}
	$results{$uname.':'.$udom} = \%userhash;
	}
	}
	}
	}
	return %results;
	}

	sub get_instuser {
	my ($udom,$uname,$id) = @_;
	my $homeserver = &domain($udom,'primary');
	my ($outcome,%results);
	if ($homeserver ne '') {
	my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
	&escape($id).':'.&escape($udom),$homeserver);
	my $host=&hostname($homeserver);
	if ($queryid !~/^\Q$host\E\_/) {
	&logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
	return;
	}
	my $response = &get_query_reply($queryid);
	my $maxtries = 5;
	my $tries = 1;
	while (($response=~/^timeout/) && ($tries < $maxtries)) {
	$response = &get_query_reply($queryid);
	$tries ++;
	}
	if (!&error($response) && $response ne 'refused') {
	if ($response eq 'unavailable') {
	$outcome = $response;
	} else {
	$outcome = 'ok';
	my @matches = split(/\n/,$response);
	foreach my $match (@matches) {
	my ($key,$value) = split(/=/,$match);
	$results{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	}
	my %userinfo;
	if (ref($results{$uname}) eq 'HASH') {
	%userinfo = %{$results{$uname}};
	}
	return ($outcome,%userinfo);
	}

	sub inst_rulecheck {
	my ($udom,$uname,$id,$item,$rules) = @_;
	my %returnhash;
	if ($udom ne '') {
	if (ref($rules) eq 'ARRAY') {
	@{$rules} = map {&escape($_);} (@{$rules});
	my $rulestr = join(':',@{$rules});
	my $homeserver=&domain($udom,'primary');
	if (($homeserver ne '') && ($homeserver ne 'no_host')) {
	my $response;
	if ($item eq 'username') {
	$response=&unescape(&reply('instrulecheck:'.&escape($udom).
	':'.&escape($uname).':'.$rulestr,
	$homeserver));
	} elsif ($item eq 'id') {
	$response=&unescape(&reply('instidrulecheck:'.&escape($udom).
	':'.&escape($id).':'.$rulestr,
	$homeserver));
	} elsif ($item eq 'selfcreate') {
	$response=&unescape(&reply('instselfcreatecheck:'.
	&escape($udom).':'.&escape($uname).
	':'.$rulestr,$homeserver));
	}
	if ($response ne 'refused') {
	my @pairs=split(/\&/,$response);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
	}
	}
	}
	}
	return %returnhash;
	}

	sub inst_userrules {
	my ($udom,$check) = @_;
	my (%ruleshash,@ruleorder);
	if ($udom ne '') {
	my $homeserver=&domain($udom,'primary');
	if (($homeserver ne '') && ($homeserver ne 'no_host')) {
	my $response;
	if ($check eq 'id') {
	$response=&reply('instidrules:'.&escape($udom),
	$homeserver);
	} elsif ($check eq 'email') {
	$response=&reply('instemailrules:'.&escape($udom),
	$homeserver);
	} else {
	$response=&reply('instuserrules:'.&escape($udom),
	$homeserver);
	}
	if (($response ne 'refused') && ($response ne 'error') &&
	($response ne 'unknown_cmd') &&
	($response ne 'no_such_host')) {
	my ($hashitems,$orderitems) = split(/:/,$response);
	my @pairs=split(/\&/,$hashitems);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$ruleshash{$key}=&thaw_unescape($value);
	}
	my @esc_order = split(/\&/,$orderitems);
	foreach my $item (@esc_order) {
	push(@ruleorder,&unescape($item));
	}
	}
	}
	}
	return (\%ruleshash,\@ruleorder);
	}

	# ------------- Get Authentication, Language and User Tools Defaults for Domain

	sub get_domain_defaults {
	my ($domain) = @_;
	my $cachetime = 606024;
	my ($result,$cached)=&is_cached_new('domdefaults',$domain);
	if (defined($cached)) {
	if (ref($result) eq 'HASH') {
	return %{$result};
	}
	}
	my %domdefaults;
	my %domconfig =
	&Apache::lonnet::get_dom('configuration',['defaults','quotas',
	'requestcourses','inststatus'],$domain);
	if (ref($domconfig{'defaults'}) eq 'HASH') {
	$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
	$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
	$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
	$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
	$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
	} else {
	$domdefaults{'lang_def'} = &domain($domain,'lang_def');
	$domdefaults{'auth_def'} = &domain($domain,'auth_def');
	$domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
	}
	if (ref($domconfig{'quotas'}) eq 'HASH') {
	if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
	$domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
	} else {
	$domdefaults{'defaultquota'} = $domconfig{'quotas'};
	}
	my @usertools = ('aboutme','blog','portfolio');
	foreach my $item (@usertools) {
	if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
	$domdefaults{$item} = $domconfig{'quotas'}{$item};
	}
	}
	}
	if (ref($domconfig{'requestcourses'}) eq 'HASH') {
	foreach my $item ('official','unofficial') {
	$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
	}
	}
	if (ref($domconfig{'inststatus'}) eq 'HASH') {
	foreach my $item ('inststatustypes','inststatusorder') {
	$domdefaults{$item} = $domconfig{'inststatus'}{$item};
	}
	}
	&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
	$cachetime);
	return %domdefaults;
	}

# --------------------------------------------------- Assign a key to a student	# --------------------------------------------------- Assign a key to a student

sub assign_access_key {	sub assign_access_key {
Line 870 sub assign_access_key {	Line 1367 sub assign_access_key {
# key now belongs to user	# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;	my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {	if (&put('environment',{$envkey => $ckey}) eq 'ok') {
&appenv('environment.'.$envkey => $ckey);	&appenv({'environment.'.$envkey => $ckey});
return 'ok';	return 'ok';
} else {	} else {
return	return
Line 1114 sub do_cache_new {	Line 1611 sub do_cache_new {
$time=600;	$time=600;
}	}
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }	if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
if (!($memcache->set($id,$setvalue,$time))) {	my $result = $memcache->set($id,$setvalue,$time);
	if (! $result) {
&logthis("caching of id -> $id failed");	&logthis("caching of id -> $id failed");
	$memcache->disconnect_all();
}	}
# need to make a copy of $value	# need to make a copy of $value
#&make_room($id,$value,$debug);	&make_room($id,$value,$debug);
return $value;	return $value;
}	}

sub make_room {	sub make_room {
my ($id,$value,$debug)=@_;	my ($id,$value,$debug)=@_;
$remembered{$id}=$value;
	$remembered{$id}= (ref($value)) ? &Storable::dclone($value)
	: $value;
if ($to_remember<0) { return; }	if ($to_remember<0) { return; }
$accessed{$id}=[&gettimeofday()];	$accessed{$id}=[&gettimeofday()];
if (scalar(keys(%remembered)) <= $to_remember) { return; }	if (scalar(keys(%remembered)) <= $to_remember) { return; }
Line 1153 sub purge_remembered {	Line 1654 sub purge_remembered {

sub userenvironment {	sub userenvironment {
my ($udom,$unam,@what)=@_;	my ($udom,$unam,@what)=@_;
	my $items;
	foreach my $item (@what) {
	$items.=&escape($item).'&';
	}
	$items=~s/\&$//;
my %returnhash=();	my %returnhash=();
my @answer=split(/\&/,	my @answer=split(/\&/,
&reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),	&reply('get:'.$udom.':'.$unam.':environment:'.$items,
&homeserver($unam,$udom)));	&homeserver($unam,$udom)));
my $i;	my $i;
for ($i=0;$i<=$#what;$i++) {	for ($i=0;$i<=$#what;$i++) {
Line 1350 sub ssi_body {	Line 1856 sub ssi_body {
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {	if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
$form{'LONCAPA_INTERNAL_no_discussion'}='true';	$form{'LONCAPA_INTERNAL_no_discussion'}='true';
}	}
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output='';
&ssi($filelink,%form));	my $response;
	if ($filelink=~/^https?\:/) {
	($output,$response)=&externalssi($filelink);
	} else {
	($output,$response)=&ssi($filelink,%form);
	}
$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;	$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;
$output=~s/^.?\<body[^\>]\>//si;	$output=~s/^.?\<body[^\>]\>//si;
$output=~s/(.)\<\/body\s\>.*?$/$1/si;	$output=~s/\<\/body\s\>.?$//si;
return $output;	if (wantarray) {
	return ($output, $response);
	} else {
	return $output;
	}
}	}

# --------------------------------------------------------- Server Side Include	# --------------------------------------------------------- Server Side Include
Line 1369 sub absolute_url {	Line 1884 sub absolute_url {
return $protocol.$host_name;	return $protocol.$host_name;
}	}

	#
	# Server side include.
	# Parameters:
	# fn Possibly encrypted resource name/id.
	# form Hash that describes how the rendering should be done
	# and other things.
	# Returns:
	# Scalar context: The content of the response.
	# Array context: 2 element list of the content and the full response object.
	#
sub ssi {	sub ssi {

my ($fn,%form)=@_;	my ($fn,%form)=@_;

my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;

my $request;	my $request;

$form{'no_update_last_known'}=1;	$form{'no_update_last_known'}=1;
	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);	$request=new HTTP::Request('POST',&absolute_url().$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));	$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
Line 1389 sub ssi {	Line 1912 sub ssi {
$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $response=$ua->request($request);	my $response=$ua->request($request);

return $response->content;	if (wantarray) {
	return ($response->content, $response);
	} else {
	return $response->content;
	}
}	}

sub externalssi {	sub externalssi {
Line 1397 sub externalssi {	Line 1924 sub externalssi {
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',$url);	my $request=new HTTP::Request('GET',$url);
my $response=$ua->request($request);	my $response=$ua->request($request);
return $response->content;	if (wantarray) {
	return ($response->content, $response);
	} else {
	return $response->content;
	}
}	}

# -------------------------------- Allow a /uploaded/ URI to be vouched for	# -------------------------------- Allow a /uploaded/ URI to be vouched for
Line 1410 sub allowuploaded {	Line 1941 sub allowuploaded {
my %httpref=();	my %httpref=();
my $httpurl=&hreflocation('',$url);	my $httpurl=&hreflocation('',$url);
$httpref{'httpref.'.$httpurl}=$srcurl;	$httpref{'httpref.'.$httpurl}=$srcurl;
&Apache::lonnet::appenv(%httpref);	&Apache::lonnet::appenv(\%httpref);
}	}

# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course	# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
Line 1471 sub process_coursefile {	Line 2002 sub process_coursefile {
print $fh $env{'form.'.$source};	print $fh $env{'form.'.$source};
close($fh);	close($fh);
if ($parser eq 'parse') {	if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);	my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
unless ($parse_result eq 'ok') {	unless ($parse_result eq 'ok') {
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);	&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
}	}
Line 1550 sub clean_filename {	Line 2081 sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;	$fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;	return $fname;
}	}
	#This Function check if a Image max 400px width and height 500px. If not then scale the image down
	sub resizeImage {
	my($img_url) = @_;
	my $ima = Image::Magick->new;
	$ima->Read($img_url);
	if($ima->Get('width') > 400)
	{
	my $factor = $ima->Get('width')/400;
	$ima->Scale( width=>400, height=>$ima->Get('height')/$factor );
	}
	if($ima->Get('height') > 500)
	{
	my $factor = $ima->Get('height')/500;
	$ima->Scale( width=>$ima->Get('width')/$factor, height=>500);
	}

	$ima->Write($img_url);
	}

	#Wrapper function for userphotoupload
	sub userphotoupload
	{
	my($formname,$subdir) = @_;
	$upload_photo_form = 1;
	return &userfileupload($formname,undef,$subdir);
	}

# --------------- Take an uploaded file and put it into the userfiles directory	# --------------- Take an uploaded file and put it into the userfiles directory
# input: $formname - the contents of the file are in $env{"form.$formname"}	# input: $formname - the contents of the file are in $env{"form.$formname"}
Line 1650 sub finishuserfileupload {	Line 2207 sub finishuserfileupload {
$thumbwidth,$thumbheight) = @_;	$thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';	my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};	my $filepath=$perlvar{'lonDocRoot'};

my ($fnamepath,$file,$fetchthumb);	my ($fnamepath,$file,$fetchthumb);
$file=$fname;	$file=$fname;
if ($fname=~m\|/\|) {	if ($fname=~m\|/\|) {
Line 1664 sub finishuserfileupload {	Line 2222 sub finishuserfileupload {
mkdir($filepath,0777);	mkdir($filepath,0777);
}	}
}	}

# Save the file	# Save the file
{	{
if (!open(FH,'>'.$filepath.'/'.$file)) {	if (!open(FH,'>'.$filepath.'/'.$file)) {
Line 1677 sub finishuserfileupload {	Line 2236 sub finishuserfileupload {
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
close(FH);	close(FH);
	if($upload_photo_form==1)
	{
	resizeImage($filepath.'/'.$file);
	$upload_photo_form = 0;
	}
}	}
if ($parser eq 'parse') {	if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,	my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
$codebase);	$codebase);
unless ($parse_result eq 'ok') {	unless ($parse_result eq 'ok') {
&logthis('Failed to parse '.$filepath.$file.	&logthis('Failed to parse '.$filepath.$file.
Line 1698 sub finishuserfileupload {	Line 2262 sub finishuserfileupload {

# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
my $docuhome=&homeserver($docuname,$docudom);	my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);	my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
if ($fetchthumb) {	if ($fetchthumb) {
Line 1719 sub finishuserfileupload {	Line 2283 sub finishuserfileupload {
}	}

sub extract_embedded_items {	sub extract_embedded_items {
my ($filepath,$file,$allfiles,$codebase,$content) = @_;	my ($fullpath,$allfiles,$codebase,$content) = @_;
my @state = ();	my @state = ();
my %javafiles = (	my %javafiles = (
codebase => '',	codebase => '',
Line 1734 sub extract_embedded_items {	Line 2298 sub extract_embedded_items {
if ($content) {	if ($content) {
$p = HTML::LCParser->new($content);	$p = HTML::LCParser->new($content);
} else {	} else {
$p = HTML::LCParser->new($filepath.'/'.$file);	$p = HTML::LCParser->new($fullpath);
}	}
while (my $t=$p->get_token()) {	while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {	if ($t->[0] eq 'S') {
my ($tagname, $attr) = ($t->[1],$t->[2]);	my ($tagname, $attr) = ($t->[1],$t->[2]);
push (@state, $tagname);	push(@state, $tagname);
if (lc($tagname) eq 'allow') {	if (lc($tagname) eq 'allow') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
if (lc($tagname) eq 'img') {	if (lc($tagname) eq 'img') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
	if (lc($tagname) eq 'a') {
	&add_filetype($allfiles,$attr->{'href'},'href');
	}
if (lc($tagname) eq 'script') {	if (lc($tagname) eq 'script') {
if ($attr->{'archive'} =~ /\.jar$/i) {	if ($attr->{'archive'} =~ /\.jar$/i) {
&add_filetype($allfiles,$attr->{'archive'},'archive');	&add_filetype($allfiles,$attr->{'archive'},'archive');
Line 1827 sub add_filetype {	Line 2394 sub add_filetype {
}	}

sub removeuploadedurl {	sub removeuploadedurl {
my ($url)=@_;	my ($url)=@_;
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);	my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
return &removeuserfile($uname,$udom,$fname);	return &removeuserfile($uname,$udom,$fname);
}	}

sub removeuserfile {	sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;	my ($docuname,$docudom,$fname)=@_;
my $home=&homeserver($docuname,$docudom);	my $home=&homeserver($docuname,$docudom);
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);	my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
if ($result eq 'ok') {	if ($result eq 'ok') {
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {	if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
my $metafile = $fname.'.meta';	my $metafile = $fname.'.meta';
my $metaresult = &removeuserfile($docuname,$docudom,$metafile);	my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
my $url = "/uploaded/$docudom/$docuname/$fname";	my $url = "/uploaded/$docudom/$docuname/$fname";
my ($file,$group) = (&parse_portfolio_url($url))[3,4];	my ($file,$group) = (&parse_portfolio_url($url))[3,4];
my $sqlresult =	my $sqlresult =
&update_portfolio_table($docuname,$docudom,$file,	&update_portfolio_table($docuname,$docudom,$file,
'portfolio_metadata',$group,	'portfolio_metadata',$group,
Line 1902 sub flushcourselogs {	Line 2469 sub flushcourselogs {
# times and course titles for all courseids	# times and course titles for all courseids
#	#
my %courseidbuffer=();	my %courseidbuffer=();
foreach my $crsid (keys %courselogs) {	foreach my $crsid (keys(%courselogs)) {
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.	if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
&escape($courselogs{$crsid}),	&escape($courselogs{$crsid}),
$coursehombuf{$crsid}) eq 'ok') {	$coursehombuf{$crsid}) eq 'ok') {
Line 1915 sub flushcourselogs {	Line 2482 sub flushcourselogs {
delete $courselogs{$crsid};	delete $courselogs{$crsid};
}	}
}	}
if ($courseidbuffer{$coursehombuf{$crsid}}) {	$courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.	'description' => $coursedescrbuf{$crsid},
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).	'inst_code' => $courseinstcodebuf{$crsid},
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});	'type' => $coursetypebuf{$crsid},
} else {	'owner' => $courseownerbuf{$crsid},
$courseidbuffer{$coursehombuf{$crsid}}=	};
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
}
}	}
#	#
# Write course id database (reverse lookup) to homeserver of courses	# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse	# Is used in pickcourse
#	#
foreach my $crs_home (keys(%courseidbuffer)) {	foreach my $crs_home (keys(%courseidbuffer)) {
&courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},	my $response = &courseidput(&host_domain($crs_home),
$crs_home);	$courseidbuffer{$crs_home},
	$crs_home,'timeonly');
}	}
#	#
# File accesses	# File accesses
Line 1987 sub flushcourselogs {	Line 2552 sub flushcourselogs {
#	#
my %domrolebuffer = ();	my %domrolebuffer = ();
foreach my $entry (keys %domainrolehash) {	foreach my $entry (keys %domainrolehash) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;	my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
if ($domrolebuffer{$rudom}) {	if ($domrolebuffer{$rudom}) {
$domrolebuffer{$rudom}.='&'.&escape($entry).	$domrolebuffer{$rudom}.='&'.&escape($entry).
'='.&escape($domainrolehash{$entry});	'='.&escape($domainrolehash{$entry});
Line 2046 sub courseacclog {	Line 2611 sub courseacclog {
# FIXME: Probably ought to escape things....	# FIXME: Probably ought to escape things....
foreach my $key (keys(%env)) {	foreach my $key (keys(%env)) {
if ($key=~/^form\.(.*)/) {	if ($key=~/^form\.(.*)/) {
$what.=':'.$1.'='.$env{$key};	my $formitem = $1;
	if ($formitem =~ /^HWFILE(?:SIZE\|TOOBIG)/) {
	$what.=':'.$formitem.'='.$env{$key};
	} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
	$what.=':'.$formitem.'='.$env{$key};
	}
}	}
}	}
} elsif ($fnsymb =~ m:^/adm/searchcat:) {	} elsif ($fnsymb =~ m:^/adm/searchcat:) {
Line 2092 sub userrolelog {	Line 2662 sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;	=$tend.':'.$tstart;
}	}
	if (($env{'request.role'} =~ /dc\./) &&
	(($trole=~/^au/) \|\| ($trole=~/^in/) \|\|
	($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|
	($trole=~/^cr/) \|\| ($trole=~/^ta/))) {
	$userrolehash
	{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
	=$tend.':'.$tstart;
	}
if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|	if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|
($trole=~/^li/) \|\| ($trole=~/^li/) \|\|	($trole=~/^li/) \|\| ($trole=~/^li/) \|\|
($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|	($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|
Line 2103 sub userrolelog {	Line 2681 sub userrolelog {
}	}
}	}

	sub courserolelog {
	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
	if (($trole eq 'cc') \|\| ($trole eq 'in') \|\|
	($trole eq 'ep') \|\| ($trole eq 'ad') \|\|
	($trole eq 'ta') \|\| ($trole eq 'st') \|\|
	($trole=~/^cr/) \|\| ($trole eq 'gr')) {
	if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
	my $cdom = $1;
	my $cnum = $2;
	my $sec = $3;
	my $namespace = 'rolelog';
	my %storehash = (
	role => $trole,
	start => $tstart,
	end => $tend,
	selfenroll => $selfenroll,
	context => $context,
	);
	if ($trole eq 'gr') {
	$namespace = 'groupslog';
	$storehash{'group'} = $sec;
	} else {
	$storehash{'section'} = $sec;
	}
	&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
	}
	}
	return;
	}

sub get_course_adv_roles {	sub get_course_adv_roles {
my $cid=shift;	my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));	$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);	my %coursehash=&coursedescription($cid);
	my $crstype = &Apache::loncommon::course_type($cid);
my %nothide=();	my %nothide=();
foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
$nothide{join(':',split(/[\@\:]/,$user))}=1;	if ($user !~ /:/) {
	$nothide{join(':',split(/[\@]/,$user))}=1;
	} else {
	$nothide{$user}=1;
	}
}	}
my %returnhash=();	my %returnhash=();
my %dumphash=	my %dumphash=
Line 2125 sub get_course_adv_roles {	Line 2738 sub get_course_adv_roles {
if ((&privileged($username,$domain)) &&	if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }	(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }	if ($role eq 'cr') { next; }
my $key=&plaintext($role);	if ($codes) {
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $role .= ':'.$section; }
if ($returnhash{$key}) {	if ($returnhash{$role}) {
$returnhash{$key}.=','.$username.':'.$domain;	$returnhash{$role}.=','.$username.':'.$domain;
	} else {
	$returnhash{$role}=$username.':'.$domain;
	}
} else {	} else {
$returnhash{$key}=$username.':'.$domain;	my $key=&plaintext($role,$crstype);
	if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
	if ($returnhash{$key}) {
	$returnhash{$key}.=','.$username.':'.$domain;
	} else {
	$returnhash{$key}=$username.':'.$domain;
	}
}	}
}	}
return %returnhash;	return %returnhash;
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;	my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }	unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }	unless (defined($udom)) { $udom=$env{'user.domain'}; }
my %dumphash;	my (%dumphash,%nothide);
if ($context eq 'userroles') {	if ($context eq 'userroles') {
%dumphash = &dump('roles',$udom,$uname);	%dumphash = &dump('roles',$udom,$uname);
} else {	} else {
%dumphash=	%dumphash=
&dump('nohist_userroles',$udom,$uname);	&dump('nohist_userroles',$udom,$uname);
	if ($hidepriv) {
	my %coursehash=&coursedescription($udom.'_'.$uname);
	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
	if ($user !~ /:/) {
	$nothide{join(':',split(/[\@]/,$user))} = 1;
	} else {
	$nothide{$user} = 1;
	}
	}
	}
}	}
my %returnhash=();	my %returnhash=();
my $now=time;	my $now=time;
Line 2158 sub get_my_roles {	Line 2790 sub get_my_roles {
}	}
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
my $status = 'active';	my $status = 'active';
if (($tend) && ($tend<$now)) {	if (($tend) && ($tend<=$now)) {
$status = 'previous';	$status = 'previous';
}	}
if (($tstart) && ($now<$tstart)) {	if (($tstart) && ($now<$tstart)) {
Line 2187 sub get_my_roles {	Line 2819 sub get_my_roles {
}	}
if (ref($roles) eq 'ARRAY') {	if (ref($roles) eq 'ARRAY') {
if (!grep(/^\Q$role\E$/,@{$roles})) {	if (!grep(/^\Q$role\E$/,@{$roles})) {
	if ($role =~ /^cr\//) {
	if (!grep(/^cr$/,@{$roles})) {
	next;
	}
	} else {
	next;
	}
	}
	}
	if ($hidepriv) {
	if ((&privileged($username,$domain)) &&
	(!$nothide{$username.':'.$domain})) {
next;	next;
}	}
}	}
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	if ($withsec) {
	$returnhash{$username.':'.$domain.':'.$role.':'.$section} =
	$tstart.':'.$tend;
	} else {
	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
	}
}	}
return %returnhash;	return %returnhash;
}	}
Line 2229 sub getannounce {	Line 2878 sub getannounce {
#	#

sub courseidput {	sub courseidput {
my ($domain,$what,$coursehome)=@_;	my ($domain,$storehash,$coursehome,$caller) = @_;
return &reply('courseidput:'.$domain.':'.$what,$coursehome);	my $outcome;
	if ($caller eq 'timeonly') {
	my $cids = '';
	foreach my $item (keys(%$storehash)) {
	$cids.=&escape($item).'&';
	}
	$cids=~s/\&$//;
	$outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
	$coursehome);
	} else {
	my $items = '';
	foreach my $item (keys(%$storehash)) {
	$items.= &escape($item).'='.
	&freeze_escape($$storehash{$item}).'&';
	}
	$items=~s/\&$//;
	$outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
	$coursehome);
	}
	if ($outcome eq 'unknown_cmd') {
	my $what;
	foreach my $cid (keys(%$storehash)) {
	$what .= &escape($cid).'=';
	foreach my $item ('description','inst_code','owner','type') {
	$what .= &escape($storehash->{$cid}{$item}).':';
	}
	$what =~ s/\:$/&/;
	}
	$what =~ s/\&$//;
	return &reply('courseidput:'.$domain.':'.$what,$coursehome);
	} else {
	return $outcome;
	}
}	}

sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
my %returnhash=();	$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
unless ($domfilter) { $domfilter=''; }	$selfenrollonly,$catfilter,$showhidden,$caller)=@_;
	my $as_hash = 1;
	my %returnhash;
	if (!$domfilter) { $domfilter=''; }
my %libserv = &all_library();	my %libserv = &all_library();
foreach my $tryserver (keys(%libserv)) {	foreach my $tryserver (keys(%libserv)) {
if ( ( $hostidflag == 1	if ( ( $hostidflag == 1
&& grep(/^\Q$tryserver\E$/,@{$hostidref}) )	&& grep(/^\Q$tryserver\E$/,@{$hostidref}) )
\|\| (!defined($hostidflag)) ) {	\|\| (!defined($hostidflag)) ) {

if ($domfilter eq ''	if (($domfilter eq '') \|\|
\|\| (&host_domain($tryserver) eq $domfilter)) {	(&host_domain($tryserver) eq $domfilter)) {
foreach my $line (	my $rep =
split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.	&reply('courseiddump:'.&host_domain($tryserver).':'.
$sincefilter.':'.&escape($descfilter).':'.	$sincefilter.':'.&escape($descfilter).':'.
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),	&escape($instcodefilter).':'.&escape($ownerfilter).
$tryserver))) {	':'.&escape($coursefilter).':'.&escape($typefilter).
my ($key,$value)=split(/\=/,$line,2);	':'.&escape($regexp_ok).':'.$as_hash.':'.
if (($key) && ($value)) {	&escape($selfenrollonly).':'.&escape($catfilter).':'.
$returnhash{&unescape($key)}=$value;	$showhidden.':'.$caller,$tryserver);
}	my @pairs=split(/\&/,$rep);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/\=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	my $result = &thaw_unescape($value);
	if (ref($result) eq 'HASH') {
	$returnhash{$key}=$result;
	} else {
	my @responses = split(/:/,$value);
	my @items = ('description','inst_code','owner','type');
	for (my $i=0; $i<@responses; $i++) {
	$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
	}
	}
}	}
}	}
}	}
Line 2299 sub get_domain_roles {	Line 2997 sub get_domain_roles {
if (undef($enddate) \|\| $enddate eq '') {	if (undef($enddate) \|\| $enddate eq '') {
$enddate = '.';	$enddate = '.';
}	}
my $rolelist = join(':',@{$roles});	my $rolelist;
	if (ref($roles) eq 'ARRAY') {
	$rolelist = join(':',@{$roles});
	}
my %personnel = ();	my %personnel = ();

my %servers = &get_servers($dom,'library');	my %servers = &get_servers($dom,'library');
Line 2325 sub get_first_access {	Line 3026 sub get_first_access {
my ($symb,$courseid,$udom,$uname)=&whichuser();	my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }	if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {	if ($type eq 'course') {
	$res='course';
	} elsif ($type eq 'map') {
$res=&symbread($map);	$res=&symbread($map);
} else {	} else {
$res=$symb;	$res=$symb;
Line 2338 sub set_first_access {	Line 3041 sub set_first_access {
my ($type)=@_;	my ($type)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();	my ($symb,$courseid,$udom,$uname)=&whichuser();
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {	if ($type eq 'course') {
	$res='course';
	} elsif ($type eq 'map') {
$res=&symbread($map);	$res=&symbread($map);
} else {	} else {
$res=$symb;	$res=$symb;
Line 2968 sub coursedescription {	Line 3673 sub coursedescription {
}	}
}	}
if (!$args->{'one_time'}) {	if (!$args->{'one_time'}) {
&appenv(%envhash);	&appenv(\%envhash);
}	}
return %returnhash;	return %returnhash;
}	}
Line 3007 sub privileged {	Line 3712 sub privileged {

sub rolesinit {	sub rolesinit {
my ($domain,$username,$authhost)=@_;	my ($domain,$username,$authhost)=@_;
	my %userroles;
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);	my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return ''; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return \%userroles; }
my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();
my $now=time;	my $now=time;
my %userroles = ('user.login.time' => $now);	%userroles = ('user.login.time' => $now);
my $group_privs;	my $group_privs;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
Line 3153 sub set_userprivs {	Line 3859 sub set_userprivs {
}	}
foreach my $role (keys(%{$allroles})) {	foreach my $role (keys(%{$allroles})) {
my %thesepriv;	my %thesepriv;
if (($role=~/^au/) \|\| ($role=~/^ca/)) { $author=1; }	if (($role=~/^au/) \|\| ($role=~/^ca/) \|\| ($role=~/^aa/)) { $author=1; }
foreach my $item (split(/:/,$$allroles{$role})) {	foreach my $item (split(/:/,$$allroles{$role})) {
if ($item ne '') {	if ($item ne '') {
my ($privilege,$restrictions)=split(/&/,$item);	my ($privilege,$restrictions)=split(/&/,$item);
Line 3209 sub del {	Line 3915 sub del {
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
$items.=&escape($item).'&';	$items.=&escape($item).'&';
}	}

$items=~s/\&$//;	$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);

return &reply("del:$udomain:$uname:$namespace:$items",$uhome);	return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}	}

Line 3517 sub tmpget {	Line 4223 sub tmpget {
my %returnhash;	my %returnhash;
foreach my $item (split(/\&/,$rep)) {	foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);	my ($key,$value)=split(/=/,$item);
	next if ($key =~ /^error: 2 /);
$returnhash{&unescape($key)}=&thaw_unescape($value);	$returnhash{&unescape($key)}=&thaw_unescape($value);
}	}
return %returnhash;	return %returnhash;
Line 3772 sub is_portfolio_file {	Line 4479 sub is_portfolio_file {
return;	return;
}	}

	sub usertools_access {
	my ($uname,$udom,$tool,$action,$context) = @_;
	my ($access,%tools);
	if ($context eq '') {
	$context = 'tools';
	}
	if ($context eq 'requestcourses') {
	%tools = (
	official => 1,
	unofficial => 1,
	);
	} else {
	%tools = (
	aboutme => 1,
	blog => 1,
	portfolio => 1,
	);
	}
	return if (!defined($tools{$tool}));

	if ((!defined($udom)) \|\| (!defined($uname))) {
	$udom = $env{'user.domain'};
	$uname = $env{'user.name'};
	}

	if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
	if ($action ne 'reload') {
	if ($context eq 'requestcourses') {
	return $env{'environment.canrequest.'.$tool};
	} else {
	return $env{'environment.availabletools.'.$tool};
	}
	}
	}

	my ($toolstatus,$inststatus);

	if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
	($action ne 'reload')) {
	$toolstatus = $env{'environment.'.$context.'.'.$tool};
	$inststatus = $env{'environment.inststatus'};
	} else {
	my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);
	$toolstatus = $userenv{$context.'.'.$tool};
	$inststatus = $userenv{'inststatus'};
	}

	if ($toolstatus ne '') {
	if ($toolstatus) {
	$access = 1;
	} else {
	$access = 0;
	}
	return $access;
	}

	my $is_adv = &is_advanced_user($udom,$uname);
	my %domdef = &get_domain_defaults($udom);
	if (ref($domdef{$tool}) eq 'HASH') {
	if ($is_adv) {
	if ($domdef{$tool}{'_LC_adv'} ne '') {
	if ($domdef{$tool}{'_LC_adv'}) {
	$access = 1;
	} else {
	$access = 0;
	}
	return $access;
	}
	}
	if ($inststatus ne '') {
	my ($hasaccess,$hasnoaccess);
	foreach my $affiliation (split(/:/,$inststatus)) {
	if ($domdef{$tool}{$affiliation} ne '') {
	if ($domdef{$tool}{$affiliation}) {
	$hasaccess = 1;
	} else {
	$hasnoaccess = 1;
	}
	}
	}
	if ($hasaccess \|\| $hasnoaccess) {
	if ($hasaccess) {
	$access = 1;
	} elsif ($hasnoaccess) {
	$access = 0;
	}
	return $access;
	}
	} else {
	if ($domdef{$tool}{'default'} ne '') {
	if ($domdef{$tool}{'default'}) {
	$access = 1;
	} elsif ($domdef{$tool}{'default'} == 0) {
	$access = 0;
	}
	return $access;
	}
	}
	} else {
	if ($context eq 'tools') {
	$access = 1;
	} else {
	$access = 0;
	}
	return $access;
	}
	}

	sub is_advanced_user {
	my ($udom,$uname) = @_;
	my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
	my %allroles;
	my $is_adv;
	foreach my $role (keys(%roleshash)) {
	my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
	my $area = '/'.$tdomain.'/'.$trest;
	if ($sec ne '') {
	$area .= '/'.$sec;
	}
	if (($area ne '') && ($trole ne '')) {
	my $spec=$trole.'.'.$area;
	if ($trole =~ /^cr\//) {
	&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
	} elsif ($trole ne 'gr') {
	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
	}
	}
	}
	foreach my $role (keys(%allroles)) {
	last if ($is_adv);
	foreach my $item (split(/:/,$allroles{$role})) {
	if ($item ne '') {
	my ($privilege,$restrictions)=split(/&/,$item);
	if ($privilege eq 'adv') {
	$is_adv = 1;
	last;
	}
	}
	}
	}
	return $is_adv;
	}

# ---------------------------------------------- Custom access rule evaluation	# ---------------------------------------------- Custom access rule evaluation

Line 3783 sub customaccess {	Line 4632 sub customaccess {
$ucrs = &LONCAPA::clean_username($ucrs);	$ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;	my $access=0;
foreach my $right (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {	foreach my $right (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {
my ($effect,$realm,$role)=split(/\:/,$right);	my ($effect,$realm,$role,$type)=split(/\:/,$right);
if ($role) {	if ($type eq 'user') {
if ($role ne $urole) { next; }	foreach my $scope (split(/\s\,\s/,$realm)) {
}	my ($tdom,$tuname)=split(m{/},$scope);
foreach my $scope (split(/\s\,\s/,$realm)) {	if ($tdom) {
my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);	if ($tdom ne $env{'user.domain'}) { next; }
if ($tdom) {	}
if ($tdom ne $udom) { next; }	if ($tuname) {
}	if ($tuname ne $env{'user.name'}) { next; }
if ($tcrs) {	}
if ($tcrs ne $ucrs) { next; }	$access=($effect eq 'allow');
}	last;
if ($tsec) {	}
if ($tsec ne $usec) { next; }	} else {
}	if ($role) {
$access=($effect eq 'allow');	if ($role ne $urole) { next; }
last;	}
}	foreach my $scope (split(/\s\,\s/,$realm)) {
if ($realm eq '' && $role eq '') {	my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
$access=($effect eq 'allow');	if ($tdom) {
	if ($tdom ne $udom) { next; }
	}
	if ($tcrs) {
	if ($tcrs ne $ucrs) { next; }
	}
	if ($tsec) {
	if ($tsec ne $usec) { next; }
	}
	$access=($effect eq 'allow');
	last;
	}
	if ($realm eq '' && $role eq '') {
	$access=($effect eq 'allow');
	}
}	}
}	}
return $access;	return $access;
Line 3970 sub allowed {	Line 4833 sub allowed {
}	}

# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.

if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
return 'F';	return 'F';
}	}
Line 4323 sub log_query {	Line 5185 sub log_query {

sub update_portfolio_table {	sub update_portfolio_table {
my ($uname,$udom,$file_name,$query,$group,$action) = @_;	my ($uname,$udom,$file_name,$query,$group,$action) = @_;
	if ($group ne '') {
	$file_name =~s /^\Q$group\E//;
	}
my $homeserver = &homeserver($uname,$udom);	my $homeserver = &homeserver($uname,$udom);
my $queryid=	my $queryid=
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).	&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
Line 4331 sub update_portfolio_table {	Line 5196 sub update_portfolio_table {
return $reply;	return $reply;
}	}

	# -------------------------- Update MySQL allusers table

	sub update_allusers_table {
	my ($uname,$udom,$names) = @_;
	my $homeserver = &homeserver($uname,$udom);
	my $queryid=
	&reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'.
	'lastname='.&escape($names->{'lastname'}).'%%'.
	'firstname='.&escape($names->{'firstname'}).'%%'.
	'middlename='.&escape($names->{'middlename'}).'%%'.
	'generation='.&escape($names->{'generation'}).'%%'.
	'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
	'id='.&escape($names->{'id'}),$homeserver);
	my $reply = &get_query_reply($queryid);
	return $reply;
	}

# ------- Request retrieval of institutional classlists for course(s)	# ------- Request retrieval of institutional classlists for course(s)

sub fetch_enrollment_query {	sub fetch_enrollment_query {
Line 4365 sub fetch_enrollment_query {	Line 5247 sub fetch_enrollment_query {
if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} else {	} else {
my @responses = split/:/,$reply;	my @responses = split(/:/,$reply);
if ($homeserver eq $perlvar{'lonHostID'}) {	if ($homeserver eq $perlvar{'lonHostID'}) {
foreach my $line (@responses) {	foreach my $line (@responses) {
my ($key,$value) = split(/=/,$line,2);	my ($key,$value) = split(/=/,$line,2);
Line 4408 sub get_query_reply {	Line 5290 sub get_query_reply {
sleep 2;	sleep 2;
if (-e $replyfile.'.end') {	if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {	if (open(my $fh,$replyfile)) {
$reply.=<$fh>;	$reply = join('',<$fh>);
close($fh);	close($fh);
} else { return 'error: reply_file_error'; }	} else { return 'error: reply_file_error'; }
return &unescape($reply);	return &unescape($reply);
}	}
Line 4463 sub auto_run {	Line 5345 sub auto_run {
$response = 1;	$response = 1;
}	}
} else {	} else {
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver;
$response = &reply('autorun:'.$cdom,$homeserver);	if (&is_course($cdom,$cnum)) {
	$homeserver = &homeserver($cnum,$cdom);
	} else {
	$homeserver = &domain($cdom,'primary');
	}
	if ($homeserver ne 'no_host') {
	$response = &reply('autorun:'.$cdom,$homeserver);
	}
}	}
return $response;	return $response;
}	}
Line 4475 sub auto_get_sections {	Line 5364 sub auto_get_sections {
my @secs = ();	my @secs = ();
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
unless ($response eq 'refused') {	unless ($response eq 'refused') {
@secs = split/:/,$response;	@secs = split(/:/,$response);
}	}
return @secs;	return @secs;
}	}
Line 4514 sub auto_create_password {	Line 5403 sub auto_create_password {
if ($response eq 'refused') {	if ($response eq 'refused') {
$authchk = 'refused';	$authchk = 'refused';
} else {	} else {
($authparam,$create_passwd,$authchk) = split/:/,$response;	($authparam,$create_passwd,$authchk) = split(/:/,$response);
}	}
}	}
return ($authparam,$create_passwd,$authchk);	return ($authparam,$create_passwd,$authchk);
Line 4622 sub auto_instcode_format {	Line 5511 sub auto_instcode_format {
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);	$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {	if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =	my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
split/:/,$response;	split(/:/,$response);
%{$codes} = (%{$codes},&str2hash($codes_str));	%{$codes} = (%{$codes},&str2hash($codes_str));
push(@{$codetitles},&str2array($codetitles_str));	push(@{$codetitles},&str2array($codetitles_str));
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));	%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
Line 4668 sub auto_instcode_defaults {	Line 5557 sub auto_instcode_defaults {
}	}

sub auto_validate_class_sec {	sub auto_validate_class_sec {
my ($cdom,$cnum,$owner,$inst_class) = @_;	my ($cdom,$cnum,$owners,$inst_class) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver = &homeserver($cnum,$cdom);
	my $ownerlist;
	if (ref($owners) eq 'ARRAY') {
	$ownerlist = join(',',@{$owners});
	} else {
	$ownerlist = $owners;
	}
my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.	my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
&escape($owner).':'.$cdom,$homeserver);	&escape($ownerlist).':'.$cdom,$homeserver);
return $response;	return $response;
}	}

Line 4719 sub toggle_coursegroup_status {	Line 5614 sub toggle_coursegroup_status {
}	}

sub modify_group_roles {	sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;	my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;	my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
my $role = 'gr/'.&escape($userprivs);	my $role = 'gr/'.&escape($userprivs);
my ($uname,$udom) = split(/:/,$user);	my ($uname,$udom) = split(/:/,$user);
my $result = &assignrole($udom,$uname,$url,$role,$end,$start);	my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
if ($result eq 'ok') {	if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}	}
Line 4812 sub devalidate_getgroups_cache {	Line 5707 sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text	# ------------------------------------------------------------------ Plain Text

sub plaintext {	sub plaintext {
my ($short,$type,$cid) = @_;	my ($short,$type,$cid,$forcedefault) = @_;
if ($short =~ /^cr/) {	if ($short =~ /^cr/) {
return (split('/',$short))[-1];	return (split('/',$short))[-1];
}	}
if (!defined($cid)) {	if (!defined($cid)) {
$cid = $env{'request.course.id'};	$cid = $env{'request.course.id'};
}	}
if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {	if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) {
return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.	unless ($forcedefault) {
'.plaintext'});	my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};
	&Apache::lonlocal::mt_escape(\$roletext);
	return &Apache::lonlocal::mt($roletext);
	}
}	}
my %rolenames = (	my %rolenames = (
Course => 'std',	Course => 'std',
Line 4839 sub plaintext {	Line 5737 sub plaintext {
# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role

sub assignrole {	sub assignrole {
my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;	my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
	$context)=@_;
my $mrole;	my $mrole;
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
my $cwosec=$url;	my $cwosec=$url;
Line 4864 sub assignrole {	Line 5763 sub assignrole {
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless ((&allowed('c'.$role,$cwosec)) \|\| &allowed('c'.$role,$udom)) {	if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
&logthis('Refused assignrole: '.	my $refused;
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	if (($env{'request.course.sec'} ne '') && ($role eq 'st')) {
$env{'user.name'}.' at '.$env{'user.domain'});	if (!(&allowed('c'.$role,$url))) {
return 'refused';	$refused = 1;
	}
	} else {
	$refused = 1;
	}
	if ($refused) {
	if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
	$refused = '';
	} else {
	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
	' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
	}
}	}
$mrole=$role;	$mrole=$role;
}	}
Line 4884 sub assignrole {	Line 5797 sub assignrole {
}	}
my $origstart = $start;	my $origstart = $start;
my $origend = $end;	my $origend = $end;
	my $delflag;
# actually delete	# actually delete
if ($deleteflag) {	if ($deleteflag) {
if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {	if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {
Line 4894 sub assignrole {	Line 5808 sub assignrole {
# set start and finish to negative values for userrolelog	# set start and finish to negative values for userrolelog
$start=-1;	$start=-1;
$end=-1;	$end=-1;
	$delflag = 1;
}	}
}	}
# send command	# send command
Line 4902 sub assignrole {	Line 5817 sub assignrole {
if ($answer eq 'ok') {	if ($answer eq 'ok') {
&userrolelog($role,$uname,$udom,$url,$start,$end);	&userrolelog($role,$uname,$udom,$url,$start,$end);
# for course roles, perform group memberships changes triggered by role change.	# for course roles, perform group memberships changes triggered by role change.
	&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
unless ($role =~ /^gr/) {	unless ($role =~ /^gr/) {
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,	&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
$origstart);	$origstart,$selfenroll,$context);
}	}
}	}
return $answer;	return $answer;
Line 4942 sub modifyuser {	Line 5858 sub modifyuser {
my ($udom, $uname, $uid,	my ($udom, $uname, $uid,
$umode, $upass, $first,	$umode, $upass, $first,
$middle, $last, $gene,	$middle, $last, $gene,
$forceid, $desiredhome, $email)=@_;	$forceid, $desiredhome, $email, $inststatus)=@_;
$udom= &LONCAPA::clean_domain($udom);	$udom= &LONCAPA::clean_domain($udom);
$uname=&LONCAPA::clean_username($uname);	$uname=&LONCAPA::clean_username($uname);
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
Line 5002 sub modifyuser {	Line 5918 sub modifyuser {
}	}
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
my @tmp=&get('environment',	my @tmp=&get('environment',
['firstname','middlename','lastname','generation'],	['firstname','middlename','lastname','generation','id',
	'permanentemail','inststatus'],
$udom,$uname);	$udom,$uname);
my %names;	my %names;
if ($tmp[0] =~ m/^error:.*/) {	if ($tmp[0] =~ m/^error:.*/) {
Line 5020 sub modifyuser {	Line 5937 sub modifyuser {
if (defined($gene)) { $names{'generation'} = $gene; }	if (defined($gene)) { $names{'generation'} = $gene; }
if ($email) {	if ($email) {
$email=~s/[^\w\@\.\-\,]//gs;	$email=~s/[^\w\@\.\-\,]//gs;
if ($email=~/\@/) { $names{'notification'} = $email;	if ($email=~/\@/) { $names{'permanentemail'} = $email; }
$names{'critnotification'} = $email;	}
$names{'permanentemail'} = $email; }	if ($uid) { $names{'id'} = $uid; }
	if (defined($inststatus)) {
	$names{'inststatus'} = '';
	my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
	if (ref($usertypes) eq 'HASH') {
	my @okstatuses;
	foreach my $item (split(/:/,$inststatus)) {
	if (defined($usertypes->{$item})) {
	push(@okstatuses,$item);
	}
	}
	if (@okstatuses) {
	$names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
	}
	}
}	}
my $reply = &put('environment', \%names, $udom,$uname);	my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }	if ($reply ne 'ok') { return 'error: '.$reply; }
	my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);	&devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.	$last.', '.$gene.', '.$email.', '.$inststatus;
$env{'user.name'}.' at '.$env{'user.domain'});	if ($env{'user.name'} ne '' && $env{'user.domain'}) {
	$logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
	} else {
	$logmsg .= ' during self creation';
	}
	&logthis($logmsg);
return 'ok';	return 'ok';
}	}

Line 5038 sub modifyuser {	Line 5975 sub modifyuser {

sub modifystudent {	sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,	my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;	$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
	$selfenroll,$context,$inststatus)=@_;
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
Line 5047 sub modifystudent {	Line 5985 sub modifystudent {
# --------------------------------------------------------------- Make the user	# --------------------------------------------------------------- Make the user
my $reply=&modifyuser	my $reply=&modifyuser
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
$desiredhome,$email);	$desiredhome,$email,$inststatus);
unless ($reply eq 'ok') { return $reply; }	unless ($reply eq 'ok') { return $reply; }
# This will cause &modify_student_enrollment to get the uid from the	# This will cause &modify_student_enrollment to get the uid from the
# students environment	# students environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$locktype,$cid);	$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
Line 5116 sub modify_student_enrollment {	Line 6054 sub modify_student_enrollment {
if ($usec) {	if ($usec) {
$uurl.='/'.$usec;	$uurl.='/'.$usec;
}	}
return &assignrole($udom,$uname,$uurl,'st',$end,$start);	return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
}	}

sub format_name {	sub format_name {
Line 5197 sub createcourse {	Line 6135 sub createcourse {
}	}
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).	my $newcourse = {
':'.&escape($inst_code).':'.&escape($course_owner).':'.	$udom.'_'.$uname => {
&escape($crstype),$uhome);	description => $description,
&flushcourselogs();	inst_code => $inst_code,
	owner => $course_owner,
	type => $crstype,
	},
	};
	&courseidput($udom,$newcourse,$uhome,'notime');
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
unless ($nonstandard) {	unless ($nonstandard) {
Line 5240 sub is_course {	Line 6183 sub is_course {
# ---------------------------------------------------------- Assign Custom Role	# ---------------------------------------------------------- Assign Custom Role

sub assigncustomrole {	sub assigncustomrole {
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;	my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,	return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
$end,$start,$deleteflag);	$end,$start,$deleteflag,$selfenroll,$context);
}	}

# ----------------------------------------------------------------- Revoke Role	# ----------------------------------------------------------------- Revoke Role

sub revokerole {	sub revokerole {
my ($udom,$uname,$url,$role,$deleteflag)=@_;	my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
my $now=time;	my $now=time;
return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);	return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
}	}

# ---------------------------------------------------------- Revoke Custom Role	# ---------------------------------------------------------- Revoke Custom Role

sub revokecustomrole {	sub revokecustomrole {
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;	my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
my $now=time;	my $now=time;
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,	return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
$deleteflag);	$deleteflag,$selfenroll,$context);
}	}

# ------------------------------------------------------------ Disk usage	# ------------------------------------------------------------ Disk usage
sub diskusage {	sub diskusage {
my ($udom,$uname,$directoryRoot)=@_;	my ($udom,$uname,$directorypath,$getpropath)=@_;
$directoryRoot =~ s/\/$//;	$directorypath =~ s/\/$//;
my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));	my $listing=&reply('du2:'.&escape($directorypath).':'
	.&escape($getpropath).':'.&escape($uname).':'
	.&escape($udom),homeserver($uname,$udom));
	if ($listing eq 'unknown_cmd') {
	if ($getpropath) {
	$directorypath = &propath($udom,$uname).'/'.$directorypath;
	}
	$listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
	}
return $listing;	return $listing;
}	}

Line 5507 sub modify_access_controls {	Line 6458 sub modify_access_controls {
}	}
}	}
}	}
	my ($group);
	if (&is_course($domain,$user)) {
	($group,my $file) = split(/\//,$file_name,2);
	}
$deloutcome = &del('file_permissions',\@deletions,$domain,$user);	$deloutcome = &del('file_permissions',\@deletions,$domain,$user);
$new_values{$file_name."\0".'accesscontrol'} = \%new_control;	$new_values{$file_name."\0".'accesscontrol'} = \%new_control;
$outcome = &put('file_permissions',\%new_values,$domain,$user);	$outcome = &put('file_permissions',\%new_values,$domain,$user);
# remove lock	# remove lock
my @del_lock = ($file_name."\0".'locked_access_records');	my @del_lock = ($file_name."\0".'locked_access_records');
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);	my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
my ($file,$group);
if (&is_course($domain,$user)) {
($group,$file) = split(/\//,$file_name,2);
} else {
$file = $file_name;
}
my $sqlresult =	my $sqlresult =
&update_portfolio_table($user,$domain,$file,'portfolio_access',	&update_portfolio_table($user,$domain,$file_name,'portfolio_access',
$group);	$group);
} else {	} else {
$outcome = "error: could not obtain lockfile\n";	$outcome = "error: could not obtain lockfile\n";
Line 5683 sub unmark_as_readonly {	Line 6632 sub unmark_as_readonly {
# ------------------------------------------------------------ Directory lister	# ------------------------------------------------------------ Directory lister

sub dirlist {	sub dirlist {
my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;	my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;

$uri=~s/^\///;	$uri=~s/^\///;
$uri=~s/\/$//;	$uri=~s/\/$//;
my ($udom, $uname);	my ($udom, $uname);
(undef,$udom,$uname)=split(/\//,$uri);	if ($getuserdir) {
if(defined($userdomain)) {
$udom = $userdomain;	$udom = $userdomain;
}
if(defined($username)) {
$uname = $username;	$uname = $username;
	} else {
	(undef,$udom,$uname)=split(/\//,$uri);
	if(defined($userdomain)) {
	$udom = $userdomain;
	}
	if(defined($username)) {
	$uname = $username;
	}
}	}
	my ($dirRoot,$listing,@listing_results);

my $dirRoot = $perlvar{'lonDocRoot'};	$dirRoot = $perlvar{'lonDocRoot'};
if(defined($alternateDirectoryRoot)) {	if (defined($getpropath)) {
$dirRoot = $alternateDirectoryRoot;	$dirRoot = &propath($udom,$uname);
$dirRoot =~ s/\/$//;	$dirRoot =~ s/\/$//;
	} elsif (defined($getuserdir)) {
	my $subdir=$uname.'__';
	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
	$dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
	."/$udom/$subdir/$uname";
	} elsif (defined($alternateRoot)) {
	$dirRoot = $alternateRoot;
}	}

if($udom) {	if($udom) {
if($uname) {	if($uname) {
my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,	$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
&homeserver($uname,$udom));	.$getuserdir.':'.&escape($dirRoot)
my @listing_results;	.':'.&escape($uname).':'.&escape($udom),
	&homeserver($uname,$udom));
	if ($listing eq 'unknown_cmd') {
	$listing = &reply('ls2:'.$dirRoot.'/'.$uri,
	&homeserver($uname,$udom));
	} else {
	@listing_results = map { &unescape($_); } split(/:/,$listing);
	}
if ($listing eq 'unknown_cmd') {	if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$dirRoot.'/'.$uri,	$listing = &reply('ls:'.$dirRoot.'/'.$uri,
&homeserver($uname,$udom));	&homeserver($uname,$udom));
Line 5715 sub dirlist {	Line 6683 sub dirlist {
@listing_results = map { &unescape($_); } split(/:/,$listing);	@listing_results = map { &unescape($_); } split(/:/,$listing);
}	}
return @listing_results;	return @listing_results;
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!$alternateRoot) {
my %allusers;	my %allusers;
my %servers = &get_servers($udom,'library');	my %servers = &get_servers($udom,'library');
foreach my $tryserver (keys(%servers)) {	foreach my $tryserver (keys(%servers)) {
my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.	$listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
$udom, $tryserver);	&escape($udom),$tryserver);
my @listing_results;	if ($listing eq 'unknown_cmd') {
	$listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
	$udom, $tryserver);
	} else {
	@listing_results = map { &unescape($_); } split(/:/,$listing);
	}
if ($listing eq 'unknown_cmd') {	if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.	$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);	$udom, $tryserver);
Line 5748 sub dirlist {	Line 6721 sub dirlist {
} else {	} else {
return ('missing user name');	return ('missing user name');
}	}
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!defined($getpropath)) {
my @all_domains = sort(&all_domains());	my @all_domains = sort(&all_domains());
foreach my $domain (@all_domains) {	foreach my $domain (@all_domains) {
$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';	$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
}	}
return @all_domains;	return @all_domains;
} else {	} else {
return ('missing domain');	return ('missing domain');
}	}
}	}
Line 5764 sub dirlist {	Line 6737 sub dirlist {
# when it was last modified. It will also return an error of -1	# when it was last modified. It will also return an error of -1
# if an error occurs	# if an error occurs

##
## FIXME: This subroutine assumes its caller knows something about the
## directory structure of the home server for the student ($root).
## Not a good assumption to make. Since this is for looking up files
## in user directories, the full path should be constructed by lond, not
## whatever machine we request data from.
##
sub GetFileTimestamp {	sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;	my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
$studentDomain = &LONCAPA::clean_domain($studentDomain);	$studentDomain = &LONCAPA::clean_domain($studentDomain);
$studentName = &LONCAPA::clean_username($studentName);	$studentName = &LONCAPA::clean_username($studentName);
my $subdir=$studentName.'__';	my ($fileStat) =
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;	&Apache::lonnet::dirlist($filename,$studentDomain,$studentName,
my $proname="$studentDomain/$subdir/$studentName";	undef,$getuserdir);
$proname .= '/'.$filename;
my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
$studentName, $root);
my @stats = split('&', $fileStat);	my @stats = split('&', $fileStat);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {	if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
# @stats contains first the filename, then the stat output	# @stats contains first the filename, then the stat output
Line 5794 sub stat_file {	Line 6757 sub stat_file {
my ($uri) = @_;	my ($uri) = @_;
$uri = &clutter_with_no_wrapper($uri);	$uri = &clutter_with_no_wrapper($uri);

my ($udom,$uname,$file,$dir);	my ($udom,$uname,$file);
if ($uri =~ m-^/(uploaded\|editupload)/-) {	if ($uri =~ m-^/(uploaded\|editupload)/-) {
($udom,$uname,$file) =	($udom,$uname,$file) =
($uri =~ m-/(?:uploaded\|editupload)/?($match_domain)/?($match_name)/?(.*)-);	($uri =~ m-/(?:uploaded\|editupload)/?($match_domain)/?($match_name)/?(.*)-);
$file = 'userfiles/'.$file;	$file = 'userfiles/'.$file;
$dir = &propath($udom,$uname);
}	}
if ($uri =~ m-^/res/-) {	if ($uri =~ m-^/res/-) {
($udom,$uname) =	($udom,$uname) =
Line 5811 sub stat_file {	Line 6773 sub stat_file {
# unable to handle the uri	# unable to handle the uri
return ();	return ();
}	}
	my $getpropath;
my ($result) = &dirlist($file,$udom,$uname,$dir);	if ($file =~ /^userfiles\//) {
	$getpropath = 1;
	}
	my ($result) = &dirlist($file,$udom,$uname,$getpropath);
my @stats = split('&', $result);	my @stats = split('&', $result);

if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {	if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
Line 5845 sub directcondval {	Line 6810 sub directcondval {
untie(%bighash);	untie(%bighash);
}	}
my $value = &docondval($sub_condition);	my $value = &docondval($sub_condition);
&appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);	&appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
return $value;	return $value;
}	}
if ($env{'user.state.'.$env{'request.course.id'}}) {	if ($env{'user.state.'.$env{'request.course.id'}}) {
Line 6002 sub resdata {	Line 6967 sub resdata {
}	}
if (!ref($result)) { return $result; }	if (!ref($result)) { return $result; }
foreach my $item (@which) {	foreach my $item (@which) {
if (defined($result->{$item})) {	if (defined($result->{$item->[0]})) {
return $result->{$item};	return [$result->{$item->[0]},$item->[1]];
}	}
}	}
return undef;	return undef;
Line 6031 sub EXT_cache_status {	Line 6996 sub EXT_cache_status {
sub EXT_cache_set {	sub EXT_cache_set {
my ($target_domain,$target_user) = @_;	my ($target_domain,$target_user) = @_;
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;	my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
#&appenv($cachename => time);	#&appenv({$cachename => time});
}	}

# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable
Line 6169 sub EXT {	Line 7134 sub EXT {
my ($map) = &decode_symb($symbparm);	my ($map) = &decode_symb($symbparm);
return &symbread($map);	return &symbread($map);
}	}
	if ($space eq 'filename') {
	if ($symbparm) {
	return &clutter((&decode_symb($symbparm))[2]);
	}
	return &hreflocation('',$env{'request.filename'});
	}

my ($section, $group, @groups);	my ($section, $group, @groups);
my ($courselevelm,$courselevel);	my ($courselevelm,$courselevel);
Line 6209 sub EXT {	Line 7180 sub EXT {
# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user

my $userreply=&resdata($uname,$udom,'user',	my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,	([$courselevelr,'resource'],
$courselevel));	[$courselevelm,'map' ],
if (defined($userreply)) { return $userreply; }	[$courselevel, 'course' ]));
	if (defined($userreply)) { return &get_reply($userreply); }

# ------------------------------------------------ second, check some of course	# ------------------------------------------------ second, check some of course
my $coursereply;	my $coursereply;
if (@groups > 0) {	if (@groups > 0) {
$coursereply = &check_group_parms($courseid,\@groups,$symbparm,	$coursereply = &check_group_parms($courseid,\@groups,$symbparm,
$mapparm,$spacequalifierrest);	$mapparm,$spacequalifierrest);
if (defined($coursereply)) { return $coursereply; }	if (defined($coursereply)) { return &get_reply($coursereply); }
}	}

$coursereply=&resdata($env{'course.'.$courseid.'.num'},	$coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',
($seclevelr,$seclevelm,$seclevel,	([$seclevelr, 'resource'],
$courselevelr));	[$seclevelm, 'map' ],
if (defined($coursereply)) { return $coursereply; }	[$seclevel, 'course' ],
	[$courselevelr,'resource']));
	if (defined($coursereply)) { return &get_reply($coursereply); }

# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
my %parmhash=();	my %parmhash=();
Line 6237 sub EXT {	Line 7211 sub EXT {
$thisparm=$parmhash{$symbparm};	$thisparm=$parmhash{$symbparm};
untie(%parmhash);	untie(%parmhash);
}	}
if ($thisparm) { return $thisparm; }	if ($thisparm) { return &get_reply([$thisparm,'resource']); }
}	}
# ------------------------------------------ fourth, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

Line 6250 sub EXT {	Line 7224 sub EXT {
$filename=$env{'request.filename'};	$filename=$env{'request.filename'};
}	}
my $metadata=&metadata($filename,$spacequalifierrest);	my $metadata=&metadata($filename,$spacequalifierrest);
if (defined($metadata)) { return $metadata; }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
if (defined($metadata)) { return $metadata; }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }

# ---------------------------------------------- fourth, look in rest pf course	# ---------------------------------------------- fourth, look in rest of course
if ($symbparm && defined($courseid) &&	if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {	$courseid eq $env{'request.course.id'}) {
my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',
($courselevelm,$courselevel));	([$courselevelm,'map' ],
if (defined($coursereply)) { return $coursereply; }	[$courselevel, 'course']));
	if (defined($coursereply)) { return &get_reply($coursereply); }
}	}
# ------------------------------------------------------------------ Cascade up	# ------------------------------------------------------------------ Cascade up
unless ($space eq '0') {	unless ($space eq '0') {
Line 6269 sub EXT {	Line 7244 sub EXT {
my $id=pop(@parts);	my $id=pop(@parts);
my $part=join('_',@parts);	my $part=join('_',@parts);
if ($part eq '') { $part='0'; }	if ($part eq '') { $part='0'; }
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,	my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
$symbparm,$udom,$uname,$section,1);	$symbparm,$udom,$uname,$section,1);
if (defined($partgeneral)) { return $partgeneral; }	if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
}	}
if ($recurse) { return undef; }	if ($recurse) { return undef; }
my $pack_def=&packages_tab_default($filename,$varname);	my $pack_def=&packages_tab_default($filename,$varname);
if (defined($pack_def)) { return $pack_def; }	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }

# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment	# ----------------------------------------------------------------- environment
Line 6304 sub EXT {	Line 7278 sub EXT {
return '';	return '';
}	}

	sub get_reply {
	my ($reply_value) = @_;
	if (ref($reply_value) eq 'ARRAY') {
	if (wantarray) {
	return @$reply_value;
	}
	return $reply_value->[0];
	} else {
	return $reply_value;
	}
	}

sub check_group_parms {	sub check_group_parms {
my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;	my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
my @groupitems = ();	my @groupitems = ();
my $resultitem;	my $resultitem;
my @levels = ($symbparm,$mapparm,$what);	my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
foreach my $group (@{$groups}) {	foreach my $group (@{$groups}) {
foreach my $level (@levels) {	foreach my $level (@levels) {
my $item = $courseid.'.['.$group.'].'.$level;	my $item = $courseid.'.['.$group.'].'.$level->[0];
push(@groupitems,$item);	push(@groupitems,[$item,$level->[1]]);
}	}
}	}
my $coursereply = &resdata($env{'course.'.$courseid.'.num'},	my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
Line 6338 sub packages_tab_default {	Line 7324 sub packages_tab_default {
$do_default=1;	$do_default=1;
} elsif ($pack_type eq 'extension') {	} elsif ($pack_type eq 'extension') {
push(@extension,[$package,$pack_type,$pack_part]);	push(@extension,[$package,$pack_type,$pack_part]);
} elsif ($pack_part eq $part) {	} elsif ($pack_part eq $part \|\| $pack_type eq 'part') {
# only look at packages defaults for packages that this id is	# only look at packages defaults for packages that this id is
push(@specifics,[$package,$pack_type,$pack_part]);	push(@specifics,[$package,$pack_type,$pack_part]);
}	}
Line 6405 sub metadata {	Line 7391 sub metadata {
if (($uri eq '') \|\|	if (($uri eq '') \|\|
(($uri =~ m\|^/*adm/\|) &&	(($uri =~ m\|^/*adm/\|) &&
($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)) \|\|	($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) ) {
($uri =~ m\|home/$match_username/public_html/\|)) {	return undef;
	}
	if (($uri =~ /^~/ \|\| $uri =~ m{home/$match_username/public_html/})
	&& &Apache::lonxml::get_state('target') =~ /^(\|meta)$/) {
return undef;	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
Line 6427 sub metadata {	Line 7416 sub metadata {
# if (! exists($metacache{$uri})) {	# if (! exists($metacache{$uri})) {
# $metacache{$uri}={};	# $metacache{$uri}={};
# }	# }
	my $cachetime = 60*60;
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
Line 6437 sub metadata {	Line 7427 sub metadata {
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;	my $metastring;
if ($uri !~ m -^(editupload)/-) {	if ($uri =~ /^~/ \|\| $uri =~ m{home/$match_username/public_html/}) {
	my $which = &hreflocation('','/'.($liburi \|\| $uri));
	$metastring =
	&Apache::lonnet::ssi_body($which,
	('grade_target' => 'meta'));
	$cachetime = 1; # only want this cached in the child not long term
	} elsif ($uri !~ m -^(editupload)/-) {
my $file=&filelocation('',&clutter($filename));	my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);	#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);	$metastring=&getfile($file);
Line 6542 sub metadata {	Line 7538 sub metadata {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$metaentry{':'.$unikey}=$default;	$metaentry{':'.$unikey}=$default;
} else {	} elsif ( $internaltext =~ /\S/ ) {
# either something interesting inside the tag or default	# something interesting inside the tag
# uninteresting
$metaentry{':'.$unikey}=$internaltext;	$metaentry{':'.$unikey}=$internaltext;
	} else {
	# no interesting values, don't set a default
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 6555 sub metadata {	Line 7552 sub metadata {
}	}
}	}
my ($extension) = ($uri =~ /\.(\w+)$/);	my ($extension) = ($uri =~ /\.(\w+)$/);
	$extension = lc($extension);
	if ($extension eq 'htm') { $extension='html'; }

foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension	#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }	if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,	&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);	\%metathesekeys);
}	}
if (!exists($metaentry{':packages'})) {
	if (!exists($metaentry{':packages'})
	\|\| $packagetab{"import_defaults&extension_$extension"}) {
foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages well let's get default then	#no specific packages well let's get default then
if ($key!~/^default&/) { next; }	if ($key!~/^default&/) { next; }
Line 6598 sub metadata {	Line 7600 sub metadata {
$metaentry{':keys'} = join(',',keys(%metathesekeys));	$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache_new('meta',$uri,\%metaentry,60*60);	&do_cache_new('meta',$uri,\%metaentry,$cachetime);
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metaentry{':'.$what};	return $metaentry{':'.$what};
Line 6680 sub gettitle {	Line 7682 sub gettitle {
}	}
my ($map,$resid,$url)=&decode_symb($symb);	my ($map,$resid,$url)=&decode_symb($symb);
my $title='';	my $title='';
my %bighash;	if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',	$title = $env{'course.'.$env{'request.course.id'}.'.description'};
&GDBM_READER(),0640)) {	} else {
my $mapid=$bighash{'map_pc_'.&clutter($map)};	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
$title=$bighash{'title_'.$mapid.'.'.$resid};	&GDBM_READER(),0640)) {
untie %bighash;	my $mapid=$bighash{'map_pc_'.&clutter($map)};
	$title=$bighash{'title_'.$mapid.'.'.$resid};
	untie(%bighash);
	}
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
Line 6893 sub symbread {	Line 7898 sub symbread {
if ($syval) {	if ($syval) {
#unless ($syval=~/\_\d+$/) {	#unless ($syval=~/\_\d+$/) {
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {	#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
#&appenv('request.ambiguous' => $thisfn);	#&appenv({'request.ambiguous' => $thisfn});
#return $env{$cache_str}='';	#return $env{$cache_str}='';
#}	#}
#$syval.=$1;	#$syval.=$1;
Line 6945 sub symbread {	Line 7950 sub symbread {
return $env{$cache_str}=$syval;	return $env{$cache_str}=$syval;
}	}
}	}
&appenv('request.ambiguous' => $thisfn);	&appenv({'request.ambiguous' => $thisfn});
return $env{$cache_str}='';	return $env{$cache_str}='';
}	}

Line 7058 sub getCODE {	Line 8063 sub getCODE {
sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();	my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {	if (!defined($symb)) {
unless ($symb=$wsymb) { return time; }	unless ($symb=$wsymb) { return time; }
}	}
if (!$courseid) { $courseid=$wcourseid; }	if (!$courseid) { $courseid=$wcourseid; }
Line 7437 sub repcopy_userfile {	Line 8442 sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }	if (-e $transferfile) { return 'ok'; }
my $request;	my $request;
$uri=~s/^\///;	$uri=~s/^\///;
$request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);	my $homeserver = &homeserver($cnum,$cdom);
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
	$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);	my $response=$ua->request($request,$transferfile);
# did it work?	# did it work?
if ($response->is_error()) {	if ($response->is_error()) {
Line 7452 sub repcopy_userfile {	Line 8460 sub repcopy_userfile {

sub tokenwrapper {	sub tokenwrapper {
my $uri=shift;	my $uri=shift;
$uri=~s\|^http\://([^/]+)\|\|;	$uri=~s\|^https?\://([^/]+)\|\|;
$uri=~s\|^/\|\|;	$uri=~s\|^/\|\|;
$env{'user.environment'}=~/\/([^\/]+)\.id/;	$env{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;	my $token=$1;
my (undef,$udom,$uname,$file)=split('/',$uri,4);	my (undef,$udom,$uname,$file)=split('/',$uri,4);
if ($udom && $uname && $file) {	if ($udom && $uname && $file) {
$file=~s\|(\?\.)$\|\|;	$file=~s\|(\?\.)$\|\|;
&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});	&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.	my $homeserver = &homeserver($uname,$udom);
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
	return $protocol.'://'.&hostname($homeserver).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
} else {	} else {
Line 7475 sub tokenwrapper {	Line 8486 sub tokenwrapper {
sub getuploaded {	sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;	$uri=~s/^\///;
$uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;	my $homeserver = &homeserver($cnum,$cdom);
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
	$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=$ua->request($request);
Line 7510 sub filelocation {	Line 8524 sub filelocation {
$file=~s-^/adm/wrapper/-/-;	$file=~s-^/adm/wrapper/-/-;
$file=~s-^/adm/coursedocs/showdoc/-/-;	$file=~s-^/adm/coursedocs/showdoc/-/-;
}	}

if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~m{^/home/$match_username/public_html/}) {	} elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference	# is a correct contruction space reference
$location = $file;	$location = $file;
	} elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
	$location = $file;
} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file	} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=	my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);	($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
Line 7524 sub filelocation {	Line 8541 sub filelocation {
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {	if ($is_me) {
$location=&propath($udom,$uname).	$location=&propath($udom,$uname).'/userfiles/'.$filename;
'/userfiles/'.$filename;
} else {	} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;	$udom.'/'.$uname.'/'.$filename;
}	}
	} elsif ($file =~ m-^/adm/-) {
	$location = $perlvar{'lonDocRoot'}.'/'.$file;
} else {	} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;	$file=~s:^/res/:/:;
Line 7540 sub filelocation {	Line 8558 sub filelocation {
}	}
}	}
$location=~s://+:/:g; # remove duplicate /	$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m{/\.\./}) {
	if ($location =~ m{/[^/]+/\.\./}) {
	$location=~ s{/[^/]+/\.\./}{/}g;
	} else {
	$location=~ s{/\.\./}{/}g;
	}
	} #remove dir/..
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;	return $location;
}	}

sub hreflocation {	sub hreflocation {
my ($dir,$file)=@_;	my ($dir,$file)=@_;
unless (($file=~m-^http://-i) \|\| ($file=~m-^/-)) {	unless (($file=~m-^https?\://-i) \|\| ($file=~m-^/-)) {
$file=filelocation($dir,$file);	$file=filelocation($dir,$file);
} elsif ($file=~m-^/adm/-) {	} elsif ($file=~m-^/adm/-) {
$file=~s-^/adm/wrapper/-/-;	$file=~s-^/adm/wrapper/-/-;
Line 7561 sub hreflocation {	Line 8585 sub hreflocation {
$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;	-/uploaded/$1/$2/-x;
}	}
	if ($file=~ m{^/userfiles/}) {
	$file =~ s{^/userfiles/}{/uploaded/};
	}
return $file;	return $file;
}	}

Line 7589 sub machine_ids {	Line 8616 sub machine_ids {
my ($hostname) = @_;	my ($hostname) = @_;
$hostname \|\|= &hostname($perlvar{'lonHostID'});	$hostname \|\|= &hostname($perlvar{'lonHostID'});
my @ids;	my @ids;
my %hostname = &all_hostnames();	my %name_to_host = &all_names();
while( my($id, $name) = each(%hostname)) {	if (ref($name_to_host{$hostname}) eq 'ARRAY') {
# &logthis("-$id-$name-$hostname-");	return @{ $name_to_host{$hostname} };
if ($hostname eq $name) {
push(@ids,$id);
}
}	}
return @ids;	return;
}	}

sub additional_machine_domains {	sub additional_machine_domains {
Line 7640 sub declutter {	Line 8664 sub declutter {

sub clutter {	sub clutter {
my $thisfn='/'.&declutter(shift);	my $thisfn='/'.&declutter(shift);
unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {	if ($thisfn !~ m{^/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)/}
	\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
if ($thisfn !~m\|/adm\|) {	if ($thisfn !~m\|/adm\|) {
Line 7742 sub get_dns {	Line 8767 sub get_dns {
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
foreach my $dns (<$config>) {	foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);	next if ($dns !~ /^\^(\S*)/x);
$alldns{$1} = 1;	my $line = $1;
	my ($host,$protocol) = split(/:/,$line);
	if ($protocol ne 'https') {
	$protocol = 'http';
	}
	$alldns{$host} = $protocol;
}	}
while (%alldns) {	while (%alldns) {
my ($dns) = keys(%alldns);	my ($dns) = keys(%alldns);
delete($alldns{$dns});
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"http://$dns$url");	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);	my $response=$ua->request($request);
	delete($alldns{$dns});
next if ($response->is_error());	next if ($response->is_error());
my @content = split("\n",$response->content);	my @content = split("\n",$response->content);
&Apache::lonnet::do_cache_new('dns',$url,\@content,302460*60);	&Apache::lonnet::do_cache_new('dns',$url,\@content,302460*60);
Line 7814 sub get_dns {	Line 8844 sub get_dns {
}	}
return $domain{$name}{$what};	return $domain{$name}{$what};
}	}

	sub domain_info {
	&load_domain_tab() if (!$loaded);
	return %domain;
	}

}	}


Line 7823 sub get_dns {	Line 8859 sub get_dns {
my %hostdom;	my %hostdom;
my %libserv;	my %libserv;
my $loaded;	my $loaded;
	my %name_to_host;

sub parse_hosts_tab {	sub parse_hosts_tab {
my ($file) = @_;	my ($file) = @_;
Line 7830 sub get_dns {	Line 8867 sub get_dns {
next if ($configline =~ /^(\#\|\s*$ )/x);	next if ($configline =~ /^(\#\|\s*$ )/x);
next if ($configline =~ /^\^/);	next if ($configline =~ /^\^/);
chomp($configline);	chomp($configline);
my ($id,$domain,$role,$name)=split(/:/,$configline);	my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline);
$name=~s/\s//g;	$name=~s/\s//g;
if ($id && $domain && $role && $name) {	if ($id && $domain && $role && $name) {
$hostname{$id}=$name;	$hostname{$id}=$name;
	push(@{$name_to_host{$name}}, $id);
$hostdom{$id}=$domain;	$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }	if ($role eq 'library') { $libserv{$id}=$name; }
	if (defined($protocol)) {
	if ($protocol eq 'https') {
	$protocol{$id} = $protocol;
	} else {
	$protocol{$id} = 'http';
	}
	} else {
	$protocol{$id} = 'http';
	}
}	}
}	}
}	}

sub reset_hosts_info {	sub reset_hosts_info {
	&purge_remembered();
&reset_domain_info();	&reset_domain_info();
&reset_hosts_ip_info();	&reset_hosts_ip_info();
	undef(%name_to_host);
undef(%hostname);	undef(%hostname);
undef(%hostdom);	undef(%hostdom);
undef(%libserv);	undef(%libserv);
Line 7872 sub get_dns {	Line 8921 sub get_dns {
return %hostname;	return %hostname;
}	}

	sub all_names {
	&load_hosts_tab() if (!$loaded);

	return %name_to_host;
	}

	sub all_host_domain {
	&load_hosts_tab() if (!$loaded);
	return %hostdom;
	}

sub is_library {	sub is_library {
&load_hosts_tab() if (!$loaded);	&load_hosts_tab() if (!$loaded);

Line 7928 sub get_dns {	Line 8988 sub get_dns {
my %name_to_ip;	my %name_to_ip;
my %lonid_to_ip;	my %lonid_to_ip;

my %valid_ip;
sub valid_ip {
my ($ip) = @_;
if (exists($iphost{$ip}) \|\| exists($valid_ip{$ip})) {
return 1;
}
my $name = gethostbyip($ip);
my $lonid = &hostname($name);
if (defined($lonid)) {
$valid_ip{$ip} = $lonid;
return 1;
}
my %iphosts = &get_iphost();
if (ref($iphost{$ip})) {
return 1;
}
}

sub get_hosts_from_ip {	sub get_hosts_from_ip {
my ($ip) = @_;	my ($ip) = @_;
my %iphosts = &get_iphost();	my %iphosts = &get_iphost();
Line 7977 sub get_dns {	Line 9019 sub get_dns {

sub get_iphost {	sub get_iphost {
my ($ignore_cache) = @_;	my ($ignore_cache) = @_;

if (!$ignore_cache) {	if (!$ignore_cache) {
if (%iphost) {	if (%iphost) {
return %iphost;	return %iphost;
Line 7990 sub get_dns {	Line 9033 sub get_dns {
return %iphost;	return %iphost;
}	}
}	}
my %hostname = &all_hostnames();
foreach my $id (keys(%hostname)) {	# get yesterday's info for fallback
my $name=&hostname($id);	my %old_name_to_ip;
	my ($ip_info,$cached)=
	&Apache::lonnet::is_cached_new('iphost','iphost');
	if ($cached) {
	%old_name_to_ip = %{$ip_info->[1]};
	}

	my %name_to_host = &all_names();
	foreach my $name (keys(%name_to_host)) {
my $ip;	my $ip;
if (!exists($name_to_ip{$name})) {	if (!exists($name_to_ip{$name})) {
$ip = gethostbyname($name);	$ip = gethostbyname($name);
if (!$ip \|\| length($ip) ne 4) {	if (!$ip \|\| length($ip) ne 4) {
&logthis("Skipping host $id name $name no IP found");	if (defined($old_name_to_ip{$name})) {
next;	$ip = $old_name_to_ip{$name};
	&logthis("Can't find $name defaulting to old $ip");
	} else {
	&logthis("Name $name no IP found");
	next;
	}
	} else {
	$ip=inet_ntoa($ip);
}	}
$ip=inet_ntoa($ip);
$name_to_ip{$name} = $ip;	$name_to_ip{$name} = $ip;
} else {	} else {
$ip = $name_to_ip{$name};	$ip = $name_to_ip{$name};
}	}
$lonid_to_ip{$id} = $ip;	foreach my $id (@{ $name_to_host{$name} }) {
push(@{$iphost{$ip}},$id);	$lonid_to_ip{$id} = $ip;
	}
	push(@{$iphost{$ip}},@{$name_to_host{$name}});
}	}
&Apache::lonnet::do_cache_new('iphost','iphost',	&Apache::lonnet::do_cache_new('iphost','iphost',
[\%iphost,\%name_to_ip,\%lonid_to_ip],	[\%iphost,\%name_to_ip,\%lonid_to_ip],
246060);	486060);

return %iphost;	return %iphost;
}	}

	#
	# Given a DNS returns the loncapa host name for that DNS
	#
	sub host_from_dns {
	my ($dns) = @_;
	my @hosts;
	my $ip;

	if (exists($name_to_ip{$dns})) {
	$ip = $name_to_ip{$dns};
	}
	if (!$ip) {
	$ip = gethostbyname($dns); # Initial translation to IP is in net order.
	if (length($ip) == 4) {
	$ip = &IO::Socket::inet_ntoa($ip);
	}
	}
	if ($ip) {
	@hosts = get_hosts_from_ip($ip);
	return $hosts[0];
	}
	return undef;
	}

}	}

BEGIN {	BEGIN {
Line 8103 $memcache=new Cache::Memcached({'servers	Line 9187 $memcache=new Cache::Memcached({'servers

$processmarker='_'.time.'_'.$perlvar{'lonHostID'};	$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;	$dumpcount=0;
	$locknum=0;

&logtouch();	&logtouch();
&logthis('<font color="yellow">INFO: Read configuration</font>');	&logthis('<font color="yellow">INFO: Read configuration</font>');
Line 8270 when the connection is brought back up	Line 9355 when the connection is brought back up
=item * B<con_failed>: unable to contact remote host and unable to save message	=item * B<con_failed>: unable to contact remote host and unable to save message
for later delivery	for later delivery

=item * B<error:>: an error a occured, a description of the error follows the :	=item * B<error:>: an error a occurred, a description of the error follows the :

=item * B<no_such_host>: unable to fund a host associated with the user/domain	=item * B<no_such_host>: unable to fund a host associated with the user/domain
that was requested	that was requested
Line 8285 that was requested	Line 9370 that was requested

=item *	=item *
X<appenv()>	X<appenv()>
B<appenv(%hash)>: the value of %hash is written to	B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to
the user envirnoment file, and will be restored for each access this	the user envirnoment file, and will be restored for each access this
user makes during this session, also modifies the %env for the current	user makes during this session, also modifies the %env for the current
process	process. Optional rolesarrayref - if defined contains a reference to an array
	of roles which are exempt from the restriction on modifying user.role entries
	in the user's environment.db and in %env.

=item *	=item *
X<delenv()>	X<delenv()>
B<delenv($regexp)>: removes all items from the session	B<delenv($delthis,$regexp)>: removes all items from the session
environment file that matches the regular expression in $regexp. The	environment file that begin with $delthis. If the
values are also delted from the current processes %env.	optional second arg - $regexp - is true, $delthis is treated as a
	regular expression, otherwise \Q$delthis\E is used.
	The values are also deleted from the current processes %env.

=item * get_env_multiple($name)	=item * get_env_multiple($name)

Line 8391 and course level	Line 9480 and course level

=item *	=item *

plaintext($short) : return value in %prp hash (rolesplain.tab); plain text	plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash
explanation of a user role term	(rolesplain.tab); plain text explanation of a user role term.
	$type is Course (default) or Group.
	If $forcedefault evaluates to true, text returned will be default
	text for $type. Otherwise, if this is a course, the text returned
	will be a custom name for the role (if defined in the course's
	environment). If no custom name is defined the default is returned.

=item *	=item *

get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :	get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
All arguments are optional. Returns a hash of a roles, either for	All arguments are optional. Returns a hash of a roles, either for
co-author/assistant author roles for a user's Construction Space	co-author/assistant author roles for a user's Construction Space
(default), or if $context is 'user', roles for the user himself,	(default), or if $context is 'userroles', roles for the user himself,
In the hash, keys are set to colon-sparated $uname,$udom,and $role,	In the hash, keys are set to colon-separated $uname,$udom,$role, and
and value is set to colon-separated start and end times for the role.	(optionally) if $withsec is true, a fourth colon-separated item - $section.
If no username and domain are specified, will default to current	For each key, value is set to colon-separated start and end times for
user/domain. Types, roles, and roledoms are references to arrays,	the role. If no username and domain are specified, will default to
	current user/domain. Types, roles, and roledoms are references to arrays
of role statuses (active, future or previous), roles	of role statuses (active, future or previous), roles
(e.g., cc,in, st etc.) and domains of the roles which can be used	(e.g., cc,in, st etc.) and domains of the roles which can be used
to restrict the list of roles reported. If no array ref is	to restrict the list of roles reported. If no array ref is
Line 8417 provided for types, will default to retu	Line 9512 provided for types, will default to retu

=item *	=item *

assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a	assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
user for the level given by URL. Optional start and end dates (leave empty	user for the level given by URL. Optional start and end dates (leave empty
string or zero for "no date")	string or zero for "no date")

Line 8434 modifyuserauth($udom,$uname,$umode,$upas	Line 9529 modifyuserauth($udom,$uname,$umode,$upas

=item *	=item *

modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :	modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
	$forceid,$desiredhome,$email,$inststatus) :
modify user	modify user

=item *	=item *

modifystudent	modifystudent

modify a students enrollment and identification information.	modify a student's enrollment and identification information.
The course id is resolved based on the current users environment.	The course id is resolved based on the current users environment.
This means the envoking user must be a course coordinator or otherwise	This means the envoking user must be a course coordinator or otherwise
associated with a course.	associated with a course.
Line 8453 Inputs:	Line 9549 Inputs:

=over 4	=over 4

=item B<$udom> Students loncapa domain	=item B<$udom> Student's loncapa domain

=item B<$uname> Students loncapa login name	=item B<$uname> Student's loncapa login name

=item B<$uid> Students id/student number	=item B<$uid> Student/Employee ID

=item B<$umode> Students authentication mode	=item B<$umode> Student's authentication mode

=item B<$upass> Students password	=item B<$upass> Student's password

=item B<$first> Students first name	=item B<$first> Student's first name

=item B<$middle> Students middle name	=item B<$middle> Student's middle name

=item B<$last> Students last name	=item B<$last> Student's last name

=item B<$gene> Students generation	=item B<$gene> Student's generation

=item B<$usec> Students section in course	=item B<$usec> Student's section in course

=item B<$end> Unix time of the roles expiration	=item B<$end> Unix time of the roles expiration

Line 8481 Inputs:	Line 9577 Inputs:

=item B<$desiredhome> server to use as home server for student	=item B<$desiredhome> server to use as home server for student

	=item B<$email> Student's permanent e-mail address

	=item B<$type> Type of enrollment (auto or manual)

	=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto

	=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC

	=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment

	=item B<$context> role change context (shown in User Management Logs display in a course)

	=item B<$inststatus> institutional status of user - : separated string of escaped status types

=back	=back

=item *	=item *
Line 8514 Inputs:	Line 9624 Inputs:

=item $start	=item $start

	=item $type

	=item $locktype

	=item $cid

	=item $selfenroll

	=item $context

=back	=back


Line 8822 Returns:	Line 9942 Returns:
'key_exists: <key>' -> failed to anything out of $storehash, as at	'key_exists: <key>' -> failed to anything out of $storehash, as at
least <key> already existed in the db (other	least <key> already existed in the db (other
requested keys may also already exist)	requested keys may also already exist)
'error: <msg>' -> unable to tie the DB or other erorr occured	'error: <msg>' -> unable to tie the DB or other error occurred
'con_lost' -> unable to contact request server	'con_lost' -> unable to contact request server
'refused' -> action was not allowed by remote machine	'refused' -> action was not allowed by remote machine

Line 8850 put_dom($namespace,$storehash,$udom,$uho	Line 9970 put_dom($namespace,$storehash,$udom,$uho
domain level either on specified domain server ($uhome) or primary domain	domain level either on specified domain server ($uhome) or primary domain
server ($udom and $uhome are optional)	server ($udom and $uhome are optional)

	=item *

	get_domain_defaults($target_domain) : returns hash with defaults for
	authentication and language in the domain. Keys are: auth_def, auth_arg_def,
	lang_def; corresponsing values are authentication type (internal, krb4, krb5,
	or localauth), initial password or a kerberos realm, language (e.g., en-us).
	Values are retrieved from cache (if current), or from domain's configuration.db
	(if available), or lastly from values in lonTabs/dns_domain,tab,
	or lonTabs/domain.tab.

	%domdefaults = &get_auth_defaults($target_domain);

=back	=back

=head2 Network Status Functions	=head2 Network Status Functions
Line 8864 dirlist($uri) : return directory list ba	Line 9996 dirlist($uri) : return directory list ba

spareserver() : find server with least workload from spare.tab	spareserver() : find server with least workload from spare.tab


	=item *

	host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
	if there is no corresponding loncapa host.

=back	=back


=head2 Apache Request	=head2 Apache Request

=over 4	=over 4

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

Removed from v.1.881
changed lines
	Added in v.1.993