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.871 and 1.977

version 1.871, 2007/04/20 21:48:09	version 1.977, 2008/12/09 11:32:03
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 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 99 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 149 sub create_connection {	Line 174 sub create_connection {
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10);	Timeout => 10);
return 0 if (!$client);	return 0 if (!$client);
print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");	print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
my $result = <$client>;	my $result = <$client>;
chomp($result);	chomp($result);
return 1 if ($result eq 'done');	return 1 if ($result eq 'done');
Line 214 sub reply {	Line 239 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

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

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

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

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

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

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

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

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

sub timed_flock {	sub timed_flock {
my ($file,$lock_type) = @_;	my ($file,$lock_type) = @_;
my $failed=0;	my $failed=0;
Line 396 sub timed_flock {	Line 473 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 428 sub delenv {	Line 518 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=~/^$delthis/) {
delete($env{$key});	delete($env{$key});
delete($disk_env{$key});	delete($disk_env{$key});
}	}
}	}
untie(%disk_env);	untie(%disk_env);
}	}
Line 458 sub get_env_multiple {	Line 549 sub get_env_multiple {
return(@values);	return(@values);
}	}

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

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

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

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

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


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

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

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

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

	return 0;
	}

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

sub changepass {	sub changepass {
Line 618 sub queryauthenticate {	Line 779 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 744 sub get_dom {	Line 919 sub get_dom {
if (defined(&domain($udom,'primary'))) {	if (defined(&domain($udom,'primary'))) {
$uhome=&domain($udom,'primary');	$uhome=&domain($udom,'primary');
} else {	} else {
$uhome eq '';	undef($uhome);
}	}
} else {	} else {
if (!$uhome) {	if (!$uhome) {
Line 756 sub get_dom {	Line 931 sub get_dom {
if ($udom && $uhome && ($uhome ne 'no_host')) {	if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);	my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
my %returnhash;	my %returnhash;
if ($rep =~ /^error: 2 /) {	if ($rep eq '' \|\| $rep =~ /^error: 2 /) {
return %returnhash;	return %returnhash;
}	}
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost\|error\|no_such_host)/i) {	if ( $#pairs==0 && $pairs[0] =~ /^(con_lost\|error\|no_such_host)/i) {
return @pairs;	return @pairs;
}	}
my %returnhash=();
my $i=0;	my $i=0;
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
$returnhash{$item}=&thaw_unescape($pairs[$i]);	$returnhash{$item}=&thaw_unescape($pairs[$i]);
Line 771 sub get_dom {	Line 945 sub get_dom {
}	}
return %returnhash;	return %returnhash;
} else {	} else {
&logthis("get_dom failed - no homeserver and/or domain");	&logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
}	}
}	}

Line 784 sub put_dom {	Line 958 sub put_dom {
if (defined(&domain($udom,'primary'))) {	if (defined(&domain($udom,'primary'))) {
$uhome=&domain($udom,'primary');	$uhome=&domain($udom,'primary');
} else {	} else {
$uhome eq '';	undef($uhome);
}	}
} else {	} else {
if (!$uhome) {	if (!$uhome) {
Line 811 sub retrieve_inst_usertypes {	Line 985 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 839 sub is_domainimage {	Line 1017 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 ($defauthtype,$defautharg,$deflang,%deftools);
	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'};
	} 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};
	}
	}
	}
	&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 871 sub assign_access_key {	Line 1300 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 1065 my $kicks=0;	Line 1494 my $kicks=0;
my $hits=0;	my $hits=0;
sub make_key {	sub make_key {
my ($name,$id) = @_;	my ($name,$id) = @_;
if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }	if (length($id) > 65
	&& length(&escape($id)) > 200) {
	$id=length($id).':'.&Digest::MD5::md5_hex($id);
	}
return &escape($name.':'.$id);	return &escape($name.':'.$id);
}	}

Line 1112 sub do_cache_new {	Line 1544 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"); }
$memcache->set($id,$setvalue,$time);	my $result = $memcache->set($id,$setvalue,$time);
	if (! $result) {
	&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 1149 sub purge_remembered {	Line 1587 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 1346 sub ssi_body {	Line 1789 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=~/^http\:/) {
	($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 1365 sub absolute_url {	Line 1817 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 1385 sub ssi {	Line 1845 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 1393 sub externalssi {	Line 1857 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 1406 sub allowuploaded {	Line 1874 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 1467 sub process_coursefile {	Line 1935 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 1547 sub clean_filename {	Line 2015 sub clean_filename {
return $fname;	return $fname;
}	}

	#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"}
# the desired filenam is in $env{"form.$formname.filename"}	# the desired filenam is in $env{"form.$formname.filename"}
Line 1673 sub finishuserfileupload {	Line 2149 sub finishuserfileupload {
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
close(FH);	close(FH);
	if($upload_photo_form==1)
	{
	my $ima = Image::Magick->new;
	$ima->Read($filepath.'/'.$file);
	if($ima->Get('width') > 300)
	{
	my $factor = $ima->Get('width')/300;
	$ima->Scale( width=>300, height=>$ima->Get('height')/$factor );
	}
	if($ima->Get('height') > 400)
	{
	my $factor = $ima->Get('height')/400;
	$ima->Scale( width=>$ima->Get('width')/$factor, height=>400);
	}


	$ima->Write($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 1715 sub finishuserfileupload {	Line 2210 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 1730 sub extract_embedded_items {	Line 2225 sub extract_embedded_items {
if ($content) {	if ($content) {
$p = HTML::LCParser->new($content);	$p = HTML::LCParser->new($content);
} else {	} else {
$p = HTML::LCParser->new($filepath.'/'.$file);	$p = HTML::LCParser->new($fullpath);
}	}
while (my $t=$p->get_token()) {	while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {	if ($t->[0] eq 'S') {
my ($tagname, $attr) = ($t->[1],$t->[2]);	my ($tagname, $attr) = ($t->[1],$t->[2]);
push (@state, $tagname);	push(@state, $tagname);
if (lc($tagname) eq 'allow') {	if (lc($tagname) eq 'allow') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
if (lc($tagname) eq 'img') {	if (lc($tagname) eq 'img') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
	if (lc($tagname) eq 'a') {
	&add_filetype($allfiles,$attr->{'href'},'href');
	}
if (lc($tagname) eq 'script') {	if (lc($tagname) eq 'script') {
if ($attr->{'archive'} =~ /\.jar$/i) {	if ($attr->{'archive'} =~ /\.jar$/i) {
&add_filetype($allfiles,$attr->{'archive'},'archive');	&add_filetype($allfiles,$attr->{'archive'},'archive');
Line 1898 sub flushcourselogs {	Line 2396 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 1911 sub flushcourselogs {	Line 2409 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 1983 sub flushcourselogs {	Line 2479 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 2042 sub courseacclog {	Line 2538 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 2088 sub userrolelog {	Line 2589 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 2099 sub userrolelog {	Line 2608 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 2121 sub get_course_adv_roles {	Line 2664 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 2154 sub get_my_roles {	Line 2716 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 2183 sub get_my_roles {	Line 2745 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 2225 sub getannounce {	Line 2804 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 2295 sub get_domain_roles {	Line 2923 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 2321 sub get_first_access {	Line 2952 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 2334 sub set_first_access {	Line 2967 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 2964 sub coursedescription {	Line 3599 sub coursedescription {
}	}
}	}
if (!$args->{'one_time'}) {	if (!$args->{'one_time'}) {
&appenv(%envhash);	&appenv(\%envhash);
}	}
return %returnhash;	return %returnhash;
}	}
Line 3003 sub privileged {	Line 3638 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 3129 sub set_userprivs {	Line 3765 sub set_userprivs {
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {	foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);	my ($trole,$area,$sec,$extendedarea);
if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {	if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
$trole = $1;	$trole = $1;
$area = $2;	$area = $2;
$sec = $3;	$sec = $3;
Line 3149 sub set_userprivs {	Line 3785 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 3513 sub tmpget {	Line 4149 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 3768 sub is_portfolio_file {	Line 4405 sub is_portfolio_file {
return;	return;
}	}

	sub usertools_access {
	my ($uname,$udom,$tool) = @_;
	my $access;
	my %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'};
	}

	my $hashid=$uname.':'.$udom;
	my ($result,$cached) = &is_cached_new('usertools.'.$tool,$hashid);
	if (defined($cached)) {
	return $result;
	}

	my ($toolstatus,$inststatus);

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

	if ($toolstatus ne '') {
	if ($toolstatus) {
	$access = 1;
	} else {
	$access = 0;
	}
	&do_cache_new('usertools.'.$tool,$hashid,$access,600);
	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;
	}
	&do_cache_new('usertools.'.$tool,$hashid,$access,600);
	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;
	}
	&do_cache_new('usertools.'.$tool,$hashid,$access,600);
	return $access;
	}
	} else {
	if ($domdef{$tool}{'default'} ne '') {
	if ($domdef{$tool}{'default'}) {
	$access = 1;
	} elsif ($domdef{$tool}{'default'} == 0) {
	$access = 0;
	}
	&do_cache_new('usertools.'.$tool,$hashid,$access,600);
	return $access;
	}
	}
	} else {
	$access = 1;
	&do_cache_new('usertools.'.$tool,$hashid,$access,600);
	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 3779 sub customaccess {	Line 4544 sub customaccess {
$ucrs = &LONCAPA::clean_username($ucrs);	$ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;	my $access=0;
foreach my $right (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {	foreach my $right (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {
my ($effect,$realm,$role)=split(/\:/,$right);	my ($effect,$realm,$role,$type)=split(/\:/,$right);
if ($role) {	if ($type eq 'user') {
if ($role ne $urole) { next; }	foreach my $scope (split(/\s\,\s/,$realm)) {
}	my ($tdom,$tuname)=split(m{/},$scope);
foreach my $scope (split(/\s\,\s/,$realm)) {	if ($tdom) {
my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);	if ($tdom ne $env{'user.domain'}) { next; }
if ($tdom) {	}
if ($tdom ne $udom) { next; }	if ($tuname) {
}	if ($tuname ne $env{'user.name'}) { next; }
if ($tcrs) {	}
if ($tcrs ne $ucrs) { next; }	$access=($effect eq 'allow');
}	last;
if ($tsec) {	}
if ($tsec ne $usec) { next; }	} else {
}	if ($role) {
$access=($effect eq 'allow');	if ($role ne $urole) { next; }
last;	}
}	foreach my $scope (split(/\s\,\s/,$realm)) {
if ($realm eq '' && $role eq '') {	my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
$access=($effect eq 'allow');	if ($tdom) {
	if ($tdom ne $udom) { next; }
	}
	if ($tcrs) {
	if ($tcrs ne $ucrs) { next; }
	}
	if ($tsec) {
	if ($tsec ne $usec) { next; }
	}
	$access=($effect eq 'allow');
	last;
	}
	if ($realm eq '' && $role eq '') {
	$access=($effect eq 'allow');
	}
}	}
}	}
return $access;	return $access;
Line 3966 sub allowed {	Line 4745 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 4319 sub log_query {	Line 5097 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 4327 sub update_portfolio_table {	Line 5108 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 4361 sub fetch_enrollment_query {	Line 5159 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 4404 sub get_query_reply {	Line 5202 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 4450 sub userlog_query {	Line 5248 sub userlog_query {

sub auto_run {	sub auto_run {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $response = 0;
my $response = &reply('autorun:'.$cdom,$homeserver);	my $settings;
	my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
	if (ref($domconfig{'autoenroll'}) eq 'HASH') {
	$settings = $domconfig{'autoenroll'};
	if ($settings->{'run'} eq '1') {
	$response = 1;
	}
	} else {
	my $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 4461 sub auto_get_sections {	Line 5276 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 4481 sub auto_validate_courseID {	Line 5296 sub auto_validate_courseID {
}	}

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam) = @_;	my ($cnum,$cdom,$authparam,$udom) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my ($homeserver,$response);
my $create_passwd = 0;	my $create_passwd = 0;
my $authchk = '';	my $authchk = '';
my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));	if ($udom =~ /^$match_domain$/) {
if ($response eq 'refused') {	$homeserver = &domain($udom,'primary');
$authchk = 'refused';	}
	if ($homeserver eq '') {
	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
	$homeserver = &homeserver($cnum,$cdom);
	}
	}
	if ($homeserver eq '') {
	$authchk = 'nodomain';
} else {	} else {
($authparam,$create_passwd,$authchk) = split/:/,$response;	$response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
	if ($response eq 'refused') {
	$authchk = 'refused';
	} else {
	($authparam,$create_passwd,$authchk) = split(/:/,$response);
	}
}	}
return ($authparam,$create_passwd,$authchk);	return ($authparam,$create_passwd,$authchk);
}	}
Line 4596 sub auto_instcode_format {	Line 5423 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 4642 sub auto_instcode_defaults {	Line 5469 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 4693 sub toggle_coursegroup_status {	Line 5526 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 4813 sub plaintext {	Line 5646 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 4838 sub assignrole {	Line 5672 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 4858 sub assignrole {	Line 5706 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 4868 sub assignrole {	Line 5717 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 4876 sub assignrole {	Line 5726 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 4916 sub modifyuser {	Line 5767 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 4976 sub modifyuser {	Line 5827 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 4994 sub modifyuser {	Line 5846 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 5012 sub modifyuser {	Line 5870 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 5027 sub modifystudent {	Line 5886 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 5090 sub modify_student_enrollment {	Line 5949 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 5171 sub createcourse {	Line 6030 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 5214 sub is_course {	Line 6078 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 5481 sub modify_access_controls {	Line 6353 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 5657 sub unmark_as_readonly {	Line 6527 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 5689 sub dirlist {	Line 6578 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 5722 sub dirlist {	Line 6616 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 5738 sub dirlist {	Line 6632 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 5768 sub stat_file {	Line 6652 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 5785 sub stat_file {	Line 6668 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 5819 sub directcondval {	Line 6705 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 5886 sub devalidatecourseresdata {	Line 6772 sub devalidatecourseresdata {


# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query
	#
	# Parameters:
	# $coursenum - Number of the course.
	# $coursedomain - Domain at which the course was created.
	# Returns:
	# A hash of the course parameters along (I think) with timestamps
	# and version info.

sub get_courseresdata {	sub get_courseresdata {
my ($coursenum,$coursedomain)=@_;	my ($coursenum,$coursedomain)=@_;
Line 5944 sub get_userresdata {	Line 6837 sub get_userresdata {
}	}
return $tmp;	return $tmp;
}	}
	#----------------------------------------------- resdata - return resource data
	# Purpose:
	# Return resource data for either users or for a course.
	# Parameters:
	# $name - Course/user name.
	# $domain - Name of the domain the user/course is registered on.
	# $type - Type of thing $name is (must be 'course' or 'user'
	# @which - Array of names of resources desired.
	# Returns:
	# The value of the first reasource in @which that is found in the
	# resource hash.
	# Exceptional Conditions:
	# If the $type passed in is not valid (not the string 'course' or
	# 'user', an undefined reference is returned.
	# If none of the resources are found, an undef is returned
sub resdata {	sub resdata {
my ($name,$domain,$type,@which)=@_;	my ($name,$domain,$type,@which)=@_;
my $result;	my $result;
Line 5955 sub resdata {	Line 6862 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 5984 sub EXT_cache_status {	Line 6891 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 6122 sub EXT {	Line 7029 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 6162 sub EXT {	Line 7075 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 6190 sub EXT {	Line 7106 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 6203 sub EXT {	Line 7119 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 6222 sub EXT {	Line 7139 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 6257 sub EXT {	Line 7173 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 6291 sub packages_tab_default {	Line 7219 sub packages_tab_default {
$do_default=1;	$do_default=1;
} elsif ($pack_type eq 'extension') {	} elsif ($pack_type eq 'extension') {
push(@extension,[$package,$pack_type,$pack_part]);	push(@extension,[$package,$pack_type,$pack_part]);
} elsif ($pack_part eq $part) {	} elsif ($pack_part eq $part \|\| $pack_type eq 'part') {
# only look at packages defaults for packages that this id is	# only look at packages defaults for packages that this id is
push(@specifics,[$package,$pack_type,$pack_part]);	push(@specifics,[$package,$pack_type,$pack_part]);
}	}
Line 6358 sub metadata {	Line 7286 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 6380 sub metadata {	Line 7311 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 6390 sub metadata {	Line 7322 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 6495 sub metadata {	Line 7433 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 6508 sub metadata {	Line 7447 sub metadata {
}	}
}	}
my ($extension) = ($uri =~ /\.(\w+)$/);	my ($extension) = ($uri =~ /\.(\w+)$/);
	$extension = lc($extension);
	if ($extension eq 'htm') { $extension='html'; }

foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension	#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }	if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,	&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);	\%metathesekeys);
}	}
if (!exists($metaentry{':packages'})) {
	if (!exists($metaentry{':packages'})
	\|\| $packagetab{"import_defaults&extension_$extension"}) {
foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages well let's get default then	#no specific packages well let's get default then
if ($key!~/^default&/) { next; }	if ($key!~/^default&/) { next; }
Line 6551 sub metadata {	Line 7495 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 6633 sub gettitle {	Line 7577 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 6846 sub symbread {	Line 7793 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 6898 sub symbread {	Line 7845 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 7011 sub getCODE {	Line 7958 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 7412 sub tokenwrapper {	Line 8359 sub tokenwrapper {
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.	return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
Line 7463 sub filelocation {	Line 8410 sub filelocation {
$file=~s-^/adm/wrapper/-/-;	$file=~s-^/adm/wrapper/-/-;
$file=~s-^/adm/coursedocs/showdoc/-/-;	$file=~s-^/adm/coursedocs/showdoc/-/-;
}	}

if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~m{^/home/$match_username/public_html/}) {	} elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference	# is a correct contruction space reference
$location = $file;	$location = $file;
	} elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
	$location = $file;
} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file	} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=	my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);	($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
Line 7477 sub filelocation {	Line 8427 sub filelocation {
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {	if ($is_me) {
$location=&propath($udom,$uname).	$location=&propath($udom,$uname).'/userfiles/'.$filename;
'/userfiles/'.$filename;
} else {	} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;	$udom.'/'.$uname.'/'.$filename;
}	}
	} elsif ($file =~ m-^/adm/-) {
	$location = $perlvar{'lonDocRoot'}.'/'.$file;
} else {	} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;	$file=~s:^/res/:/:;
Line 7493 sub filelocation {	Line 8444 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;
}	}
Line 7514 sub hreflocation {	Line 8471 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 7542 sub machine_ids {	Line 8502 sub machine_ids {
my ($hostname) = @_;	my ($hostname) = @_;
$hostname \|\|= &hostname($perlvar{'lonHostID'});	$hostname \|\|= &hostname($perlvar{'lonHostID'});
my @ids;	my @ids;
my %hostname = &all_hostnames();	my %name_to_host = &all_names();
while( my($id, $name) = each(%hostname)) {	if (ref($name_to_host{$hostname}) eq 'ARRAY') {
# &logthis("-$id-$name-$hostname-");	return @{ $name_to_host{$hostname} };
if ($hostname eq $name) {
push(@ids,$id);
}
}	}
return @ids;	return;
}	}

sub additional_machine_domains {	sub additional_machine_domains {
Line 7593 sub declutter {	Line 8550 sub declutter {

sub clutter {	sub clutter {
my $thisfn='/'.&declutter(shift);	my $thisfn='/'.&declutter(shift);
unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {	if ($thisfn !~ m{^/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)/}
	\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
if ($thisfn !~m\|/adm\|) {	if ($thisfn !~m\|/adm\|) {
Line 7767 sub get_dns {	Line 8725 sub get_dns {
}	}
return $domain{$name}{$what};	return $domain{$name}{$what};
}	}

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

}	}


Line 7776 sub get_dns {	Line 8740 sub get_dns {
my %hostdom;	my %hostdom;
my %libserv;	my %libserv;
my $loaded;	my $loaded;
	my %name_to_host;

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

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

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

	return %name_to_host;
	}

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

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

Line 7881 sub get_dns {	Line 8869 sub get_dns {
my %name_to_ip;	my %name_to_ip;
my %lonid_to_ip;	my %lonid_to_ip;

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

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

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

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

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

return %iphost;	return %iphost;
}	}
Line 8056 $memcache=new Cache::Memcached({'servers	Line 9043 $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 8223 when the connection is brought back up	Line 9211 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 8238 that was requested	Line 9226 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 8349 explanation of a user role term	Line 9339 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 8370 provided for types, will default to retu	Line 9361 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 8387 modifyuserauth($udom,$uname,$umode,$upas	Line 9378 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 8406 Inputs:	Line 9398 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 8434 Inputs:	Line 9426 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 8467 Inputs:	Line 9473 Inputs:

=item $start	=item $start

	=item $type

	=item $locktype

	=item $cid

	=item $selfenroll

	=item $context

=back	=back


Line 8504 setting for a specific $type, where $typ	Line 9520 setting for a specific $type, where $typ
@what should be a list of parameters to ask about. This routine caches	@what should be a list of parameters to ask about. This routine caches
answers for 5 minutes.	answers for 5 minutes.

	=item *

	get_courseresdata($courseid, $domain) : dump the entire course resource
	data base, returning a hash that is keyed by the resource name and has
	values that are the resource value. I believe that the timestamps and
	versions are also returned.


=back	=back

=head2 Course Modification	=head2 Course Modification
Line 8767 Returns:	Line 9791 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 8795 put_dom($namespace,$storehash,$udom,$uho	Line 9819 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 9186 symblist($mapname,%newhash) : update sym	Line 10222 symblist($mapname,%newhash) : update sym
=back	=back

=cut	=cut

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

Removed from v.1.871
changed lines
	Added in v.1.977