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.894 and 1.986

version 1.894, 2007/06/25 18:12:24	version 1.986, 2009/02/10 11:15:16
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 Image::Magick;
	use IO::Socket;

# use Date::Parse;	# use Date::Parse;
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 100 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 151 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 156 sub create_connection {	Line 183 sub create_connection {
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);
	}
	}
	}

# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
Line 320 sub convert_and_load_session_env {	Line 361 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 359 sub transfer_profile_to_env {	Line 403 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 391 sub transfer_profile_to_env {	Line 438 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 414 sub timed_flock {	Line 489 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';
}	}
Line 446 sub delenv {	Line 534 sub delenv {
"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 ($key=~/^\Q$delthis\E/) {
delete($env{$key});	delete($env{$key});
delete($disk_env{$key});	delete($disk_env{$key});
}	}
}	}
untie(%disk_env);	untie(%disk_env);
}	}
Line 476 sub get_env_multiple {	Line 565 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 485 sub userload {	Line 618 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 548 sub spareserver {	Line 682 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 582 sub compare_server_load {	Line 720 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 636 sub queryauthenticate {	Line 795 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 828 sub retrieve_inst_usertypes {	Line 1001 sub retrieve_inst_usertypes {
if (defined(&domain($udom,'primary'))) {	if (defined(&domain($udom,'primary'))) {
my $uhome=&domain($udom,'primary');	my $uhome=&domain($udom,'primary');
my $rep=&reply("inst_usertypes:$udom",$uhome);	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 ($hashitems,$orderitems) = split(/:/,$rep);
my @pairs=split(/\&/,$hashitems);	my @pairs=split(/\&/,$hashitems);
foreach my $item (@pairs) {	foreach my $item (@pairs) {
Line 856 sub is_domainimage {	Line 1033 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'],$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};
	}
	}
	&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 888 sub assign_access_key {	Line 1322 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 1132 sub do_cache_new {	Line 1566 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 1171 sub purge_remembered {	Line 1609 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 1368 sub ssi_body {	Line 1811 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 1387 sub absolute_url {	Line 1839 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 1407 sub ssi {	Line 1867 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 1415 sub externalssi {	Line 1879 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 1428 sub allowuploaded {	Line 1896 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 1489 sub process_coursefile {	Line 1957 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 1568 sub clean_filename {	Line 2036 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 1668 sub finishuserfileupload {	Line 2162 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 1682 sub finishuserfileupload {	Line 2177 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 1695 sub finishuserfileupload {	Line 2191 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 1716 sub finishuserfileupload {	Line 2217 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 1737 sub finishuserfileupload {	Line 2238 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 1752 sub extract_embedded_items {	Line 2253 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') {
Line 1848 sub add_filetype {	Line 2349 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 1923 sub flushcourselogs {	Line 2424 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 1936 sub flushcourselogs {	Line 2437 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 2008 sub flushcourselogs {	Line 2507 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 2067 sub courseacclog {	Line 2566 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 2113 sub userrolelog {	Line 2617 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 2124 sub userrolelog {	Line 2636 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 %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 2146 sub get_course_adv_roles {	Line 2692 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);
	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 2179 sub get_my_roles {	Line 2744 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 2208 sub get_my_roles {	Line 2773 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 2250 sub getannounce {	Line 2832 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 2320 sub get_domain_roles {	Line 2951 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 2346 sub get_first_access {	Line 2980 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 2359 sub set_first_access {	Line 2995 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 2989 sub coursedescription {	Line 3627 sub coursedescription {
}	}
}	}
if (!$args->{'one_time'}) {	if (!$args->{'one_time'}) {
&appenv(%envhash);	&appenv(\%envhash);
}	}
return %returnhash;	return %returnhash;
}	}
Line 3028 sub privileged {	Line 3666 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 3174 sub set_userprivs {	Line 3813 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 3230 sub del {	Line 3869 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 3538 sub tmpget {	Line 4177 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 3793 sub is_portfolio_file {	Line 4433 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 3807 sub customaccess {	Line 4589 sub customaccess {
my ($effect,$realm,$role,$type)=split(/\:/,$right);	my ($effect,$realm,$role,$type)=split(/\:/,$right);
if ($type eq 'user') {	if ($type eq 'user') {
foreach my $scope (split(/\s\,\s/,$realm)) {	foreach my $scope (split(/\s\,\s/,$realm)) {
my ($tdom,$tcrs)=split(/\_/,$scope);	my ($tdom,$tuname)=split(m{/},$scope);
if ($tdom) {	if ($tdom) {
if ($tdom ne $env{'user.domain'}) { next; }	if ($tdom ne $env{'user.domain'}) { next; }
}	}
if ($tcrs) {	if ($tuname) {
if ($tcrs ne $env{'user.name'}) { next; }	if ($tuname ne $env{'user.name'}) { next; }
}	}
$access=($effect eq 'allow');	$access=($effect eq 'allow');
last;	last;
Line 4005 sub allowed {	Line 4787 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 4358 sub log_query {	Line 5139 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 4366 sub update_portfolio_table {	Line 5150 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 4400 sub fetch_enrollment_query {	Line 5201 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 4443 sub get_query_reply {	Line 5244 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 4498 sub auto_run {	Line 5299 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 4510 sub auto_get_sections {	Line 5318 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 4549 sub auto_create_password {	Line 5357 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 4657 sub auto_instcode_format {	Line 5465 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 4703 sub auto_instcode_defaults {	Line 5511 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 4754 sub toggle_coursegroup_status {	Line 5568 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 4874 sub plaintext {	Line 5688 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 4899 sub assignrole {	Line 5714 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 4919 sub assignrole {	Line 5748 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 4929 sub assignrole {	Line 5759 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 4937 sub assignrole {	Line 5768 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 4977 sub modifyuser {	Line 5809 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 5037 sub modifyuser {	Line 5869 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 5055 sub modifyuser {	Line 5888 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'} = $inststatus; }
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 5073 sub modifyuser {	Line 5912 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)=@_;
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 5088 sub modifystudent {	Line 5928 sub modifystudent {
# 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 5151 sub modify_student_enrollment {	Line 5991 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 5232 sub createcourse {	Line 6072 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 5275 sub is_course {	Line 6120 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 5542 sub modify_access_controls {	Line 6395 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 5718 sub unmark_as_readonly {	Line 6569 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 5750 sub dirlist {	Line 6620 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 5783 sub dirlist {	Line 6658 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 5799 sub dirlist {	Line 6674 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 5829 sub stat_file {	Line 6694 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 5846 sub stat_file {	Line 6710 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 5880 sub directcondval {	Line 6747 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 6037 sub resdata {	Line 6904 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 6066 sub EXT_cache_status {	Line 6933 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 6204 sub EXT {	Line 7071 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 6244 sub EXT {	Line 7117 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 6272 sub EXT {	Line 7148 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 6285 sub EXT {	Line 7161 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 6304 sub EXT {	Line 7181 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 6339 sub EXT {	Line 7215 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 6440 sub metadata {	Line 7328 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 6462 sub metadata {	Line 7353 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 6472 sub metadata {	Line 7364 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 6577 sub metadata {	Line 7475 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 6638 sub metadata {	Line 7537 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 6720 sub gettitle {	Line 7619 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 6933 sub symbread {	Line 7835 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 6985 sub symbread {	Line 7887 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 7098 sub getCODE {	Line 8000 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 7477 sub repcopy_userfile {	Line 8379 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 7492 sub repcopy_userfile {	Line 8397 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 7515 sub tokenwrapper {	Line 8423 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 7557 sub filelocation {	Line 8468 sub filelocation {
} 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 7565 sub filelocation {	Line 8478 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;
Line 7583 sub filelocation {	Line 8495 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 7604 sub hreflocation {	Line 8522 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 7783 sub get_dns {	Line 8704 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 7855 sub get_dns {	Line 8781 sub get_dns {
}	}
return $domain{$name}{$what};	return $domain{$name}{$what};
}	}

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

}	}


Line 7872 sub get_dns {	Line 8804 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);	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(%name_to_host);
Line 7922 sub get_dns {	Line 8864 sub get_dns {
return %name_to_host;	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 8065 sub get_dns {	Line 9012 sub get_dns {
}	}
}	}

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

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

BEGIN {	BEGIN {

# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
Line 8152 $memcache=new Cache::Memcached({'servers	Line 9116 $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 8319 when the connection is brought back up	Line 9284 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 8334 that was requested	Line 9299 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()>
Line 8445 explanation of a user role term	Line 9412 explanation of a user role term

=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 8466 provided for types, will default to retu	Line 9434 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 8483 modifyuserauth($udom,$uname,$umode,$upas	Line 9451 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 8502 Inputs:	Line 9471 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 8530 Inputs:	Line 9499 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 8563 Inputs:	Line 9546 Inputs:

=item $start	=item $start

	=item $type

	=item $locktype

	=item $cid

	=item $selfenroll

	=item $context

=back	=back


Line 8871 Returns:	Line 9864 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 8899 put_dom($namespace,$storehash,$udom,$uho	Line 9892 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 8913 dirlist($uri) : return directory list ba	Line 9918 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.894
changed lines
	Added in v.1.986