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.914 and 1.1035

version 1.914, 2007/09/29 04:03:51	version 1.1035, 2009/10/24 03:24:25
Line 27	Line 27
#	#
###	###

	=pod

	=head1 NAME

	Apache::lonnet.pm

	=head1 SYNOPSIS

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

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

	=head1 Package Variables

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

	=over 4

	=item $processmarker

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

	=item $dumpcount

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

	=back

	=cut

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

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

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

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

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
Line 50 use Time::HiRes qw( gettimeofday tv_inte	Line 92 use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;	use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
use Math::Random;	use Math::Random;
	use File::MMagic;
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;

my $readit;	my $readit;
my $max_connection_retries = 10; # Or some such value.	my $max_connection_retries = 10; # Or some such value.

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

require Exporter;	require Exporter;

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

=pod

=head1 Package Variables

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

=over 4

=item $processmarker

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

=item $dumpcount

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

=back

=cut


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

Line 125 sub logthis {	Line 150 sub logthis {
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
if (open(my $fh,">>$execdir/logs/lonnet.log")) {	if (open(my $fh,">>$execdir/logs/lonnet.log")) {
print $fh "$local ($$): $message\n";	my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
	print $fh $logstring;
close($fh);	close($fh);
}	}
return 1;	return 1;
Line 156 sub create_connection {	Line 182 sub create_connection {
return 0;	return 0;
}	}

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

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

# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
Line 320 sub convert_and_load_session_env {	Line 387 sub convert_and_load_session_env {
my ($lonidsdir,$handle)=@_;	my ($lonidsdir,$handle)=@_;
my @profile;	my @profile;
{	{
open(my $idf,"$lonidsdir/$handle.id");	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
	if (!$opened) {
	return 0;
	}
flock($idf,LOCK_SH);	flock($idf,LOCK_SH);
@profile=<$idf>;	@profile=<$idf>;
close($idf);	close($idf);
Line 359 sub transfer_profile_to_env {	Line 429 sub transfer_profile_to_env {

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

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

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

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

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

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

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

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

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

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

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

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

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

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


# ------------------------------------------ Find out current server userload	# ------------------------------------------ Find out current server userload
# there is a copy in lond
sub userload {	sub userload {
my $numusers=0;	my $numusers=0;
{	{
Line 485 sub userload {	Line 651 sub userload {
my $filename;	my $filename;
my $curtime=time;	my $curtime=time;
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	next if ($filename eq '.' \|\| $filename eq '..');
	next if ($filename =~ /publicuser_\d+\.id/);
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
Line 548 sub spareserver {	Line 715 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};
	}
	if (defined($spare_server)) {
	my $hostname = &hostname($spare_server);
	if (defined($hostname)) {
	$spare_server = $protocol.'://'.$hostname;
	}
	}
}	}
return $spare_server;	return $spare_server;
}	}
Line 609 sub changepass {	Line 785 sub changepass {
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;	my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
$currentpass = &escape($currentpass);	$currentpass = &escape($currentpass);
$newpass = &escape($newpass);	$newpass = &escape($newpass);
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",	my $lonhost = $perlvar{'lonHostID'};
	my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
$server);	$server);
if (! $answer) {	if (! $answer) {
&logthis("No reply on password change request to $server ".	&logthis("No reply on password change request to $server ".
Line 634 sub changepass {	Line 811 sub changepass {
} elsif ($answer =~ "^refused") {	} elsif ($answer =~ "^refused") {
&logthis("$server refused to change $uname in $udom password because ".	&logthis("$server refused to change $uname in $udom password because ".
"it was sent an unencrypted request to change the password.");	"it was sent an unencrypted request to change the password.");
	} elsif ($answer =~ "invalid_client") {
	&logthis("$server refused to change $uname in $udom password because ".
	"it was a reset by e-mail originating from an invalid server.");
}	}
return $answer;	return $answer;
}	}
Line 657 sub queryauthenticate {	Line 837 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 769 sub idput {	Line 963 sub idput {
}	}
}	}

# ------------------------------------------- get items from domain db files	# ------------------------------dump from db file owned by domainconfig user
	sub dump_dom {
	my ($namespace,$udom,$regexp,$range)=@_;
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	my %returnhash;
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	%returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
	}
	return %returnhash;
	}

	# ------------------------------------------ get items from domain db files

sub get_dom {	sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;	my ($namespace,$storearr,$udom,$uhome)=@_;
Line 843 sub put_dom {	Line 1051 sub put_dom {
}	}
}	}

	# --------------------- newput for items in db file owned by domainconfig user
	sub newput_dom {
	my ($namespace,$storehash,$udom) = @_;
	my $result;
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	$result = &newput($namespace,$storehash,$udom,$uname);
	}
	return $result;
	}

	# --------------------- delete for items in db file owned by domainconfig user
	sub del_dom {
	my ($namespace,$storearr,$udom)=@_;
	if (ref($storearr) eq 'ARRAY') {
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	return &del($namespace,$storearr,$udom,$uname);
	}
	}
	}

	# ----------------------------------construct domainconfig user for a domain
	sub get_domainconfiguser {
	my ($udom) = @_;
	return $udom.'-domainconfig';
	}

sub retrieve_inst_usertypes {	sub retrieve_inst_usertypes {
my ($udom) = @_;	my ($udom) = @_;
my (%returnhash,@order);	my (%returnhash,@order);
if (defined(&domain($udom,'primary'))) {	my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
my $uhome=&domain($udom,'primary');	if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
my $rep=&reply("inst_usertypes:$udom",$uhome);	(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
my ($hashitems,$orderitems) = split(/:/,$rep);	%returnhash = %{$domdefs{'inststatustypes'}};
my @pairs=split(/\&/,$hashitems);	@order = @{$domdefs{'inststatusorder'}};
foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$item,2);
$key = &unescape($key);
next if ($key =~ /^error: 2 /);
$returnhash{$key}=&thaw_unescape($value);
}
my @esc_order = split(/\&/,$orderitems);
foreach my $item (@esc_order) {
push(@order,&unescape($item));
}
} else {	} else {
&logthis("get_dom failed - no primary domain server for $udom");	if (defined(&domain($udom,'primary'))) {
	my $uhome=&domain($udom,'primary');
	my $rep=&reply("inst_usertypes:$udom",$uhome);
	if ($rep =~ /^(con_lost\|error\|no_such_host\|refused)/) {
	&logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
	return (\%returnhash,\@order);
	}
	my ($hashitems,$orderitems) = split(/:/,$rep);
	my @pairs=split(/\&/,$hashitems);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
	my @esc_order = split(/\&/,$orderitems);
	foreach my $item (@esc_order) {
	push(@order,&unescape($item));
	}
	} else {
	&logthis("get_dom failed - no primary domain server for $udom");
	}
}	}
return (\%returnhash,\@order);	return (\%returnhash,\@order);
}	}
Line 1011 sub get_instuser {	Line 1264 sub get_instuser {
}	}

sub inst_rulecheck {	sub inst_rulecheck {
my ($udom,$uname,$rules) = @_;	my ($udom,$uname,$id,$item,$rules) = @_;
my %returnhash;	my %returnhash;
if ($udom ne '') {	if ($udom ne '') {
if (ref($rules) eq 'ARRAY') {	if (ref($rules) eq 'ARRAY') {
Line 1019 sub inst_rulecheck {	Line 1272 sub inst_rulecheck {
my $rulestr = join(':',@{$rules});	my $rulestr = join(':',@{$rules});
my $homeserver=&domain($udom,'primary');	my $homeserver=&domain($udom,'primary');
if (($homeserver ne '') && ($homeserver ne 'no_host')) {	if (($homeserver ne '') && ($homeserver ne 'no_host')) {
my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'.	my $response;
&escape($uname).':'.$rulestr,	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));	$homeserver));
	} elsif ($item eq 'selfcreate') {
	$response=&unescape(&reply('instselfcreatecheck:'.
	&escape($udom).':'.&escape($uname).
	':'.$rulestr,$homeserver));
	}
if ($response ne 'refused') {	if ($response ne 'refused') {
my @pairs=split(/\&/,$response);	my @pairs=split(/\&/,$response);
foreach my $item (@pairs) {	foreach my $item (@pairs) {
Line 1038 sub inst_rulecheck {	Line 1302 sub inst_rulecheck {
}	}

sub inst_userrules {	sub inst_userrules {
my ($udom) = @_;	my ($udom,$check) = @_;
my (%ruleshash,@ruleorder);	my (%ruleshash,@ruleorder);
if ($udom ne '') {	if ($udom ne '') {
my $homeserver=&domain($udom,'primary');	my $homeserver=&domain($udom,'primary');
if (($homeserver ne '') && ($homeserver ne 'no_host')) {	if (($homeserver ne '') && ($homeserver ne 'no_host')) {
my $response=&reply('instuserrules:'.&escape($udom),	my $response;
	if ($check eq 'id') {
	$response=&reply('instidrules:'.&escape($udom),
	$homeserver);
	} elsif ($check eq 'email') {
	$response=&reply('instemailrules:'.&escape($udom),
$homeserver);	$homeserver);
	} else {
	$response=&reply('instuserrules:'.&escape($udom),
	$homeserver);
	}
if (($response ne 'refused') && ($response ne 'error') &&	if (($response ne 'refused') && ($response ne 'error') &&
	($response ne 'unknown_cmd') &&
($response ne 'no_such_host')) {	($response ne 'no_such_host')) {
my ($hashitems,$orderitems) = split(/:/,$response);	my ($hashitems,$orderitems) = split(/:/,$response);
my @pairs=split(/\&/,$hashitems);	my @pairs=split(/\&/,$hashitems);
Line 1065 sub inst_userrules {	Line 1339 sub inst_userrules {
return (\%ruleshash,\@ruleorder);	return (\%ruleshash,\@ruleorder);
}	}

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

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

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

sub assign_access_key {	sub assign_access_key {
Line 1097 sub assign_access_key {	Line 1425 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 1347 sub do_cache_new {	Line 1675 sub do_cache_new {
$memcache->disconnect_all();	$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 1382 sub purge_remembered {	Line 1712 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 $uhome = &homeserver($unam,$udom);
&reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),	unless ($uhome eq 'no_host') {
&homeserver($unam,$udom)));	my @answer=split(/\&/,
my $i;	&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
for ($i=0;$i<=$#what;$i++) {	my $i;
$returnhash{$what[$i]}=&unescape($answer[$i]);	for ($i=0;$i<=$#what;$i++) {
	$returnhash{$what[$i]}=&unescape($answer[$i]);
	}
}	}
return %returnhash;	return %returnhash;
}	}
Line 1579 sub ssi_body {	Line 1916 sub ssi_body {
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {	if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
$form{'LONCAPA_INTERNAL_no_discussion'}='true';	$form{'LONCAPA_INTERNAL_no_discussion'}='true';
}	}
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output='';
&ssi($filelink,%form));	my $response;
	if ($filelink=~/^https?\:/) {
	($output,$response)=&externalssi($filelink);
	} else {
	$filelink .= $filelink=~/\?/ ? '&' : '?';
	$filelink .= 'inhibitmenu=yes';
	($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 1598 sub absolute_url {	Line 1946 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);	&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)));
} else {	} else {
$request=new HTTP::Request('GET',&absolute_url().$fn);	$request=new HTTP::Request('GET',&absolute_url().$fn);
}	}
Line 1618 sub ssi {	Line 1974 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 1626 sub externalssi {	Line 1986 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 1639 sub allowuploaded {	Line 2003 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 1700 sub process_coursefile {	Line 2064 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 $mm = new File::MMagic;
unless ($parse_result eq 'ok') {	my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);	if ($mime_type eq 'text/html') {
	my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
	unless ($parse_result eq 'ok') {
	&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
	}
}	}
}	}
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
Line 1779 sub clean_filename {	Line 2147 sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;	$fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;	return $fname;
}	}
	#This Function check if a Image max 400px width and height 500px. If not then scale the image down
	sub resizeImage {
	my($img_url) = @_;
	my $ima = Image::Magick->new;
	$ima->Read($img_url);
	if($ima->Get('width') > 400)
	{
	my $factor = $ima->Get('width')/400;
	$ima->Scale( width=>400, height=>$ima->Get('height')/$factor );
	}
	if($ima->Get('height') > 500)
	{
	my $factor = $ima->Get('height')/500;
	$ima->Scale( width=>$ima->Get('width')/$factor, height=>500);
	}

	$ima->Write($img_url);
	}

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

# --------------- Take an uploaded file and put it into the userfiles directory	# --------------- Take an uploaded file and put it into the userfiles directory
# input: $formname - the contents of the file are in $env{"form.$formname"}	# input: $formname - the contents of the file are in $env{"form.$formname"}
Line 1838 sub userfileupload {	Line 2232 sub userfileupload {
close($fh);	close($fh);
return $fullpath.'/'.$fname;	return $fullpath.'/'.$fname;
}	}
	if ($subdir eq 'scantron') {
	$fname = 'scantron_orig_'.$fname;
	} else {
# Create the directory if not present	# Create the directory if not present
$fname="$subdir/$fname";	$fname="$subdir/$fname";
	}
if ($coursedoc) {	if ($coursedoc) {
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};	my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};	my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
Line 1879 sub finishuserfileupload {	Line 2276 sub finishuserfileupload {
$thumbwidth,$thumbheight) = @_;	$thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';	my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};	my $filepath=$perlvar{'lonDocRoot'};

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

# Save the file	# Save the file
{	{
if (!open(FH,'>'.$filepath.'/'.$file)) {	if (!open(FH,'>'.$filepath.'/'.$file)) {
Line 1906 sub finishuserfileupload {	Line 2305 sub finishuserfileupload {
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
close(FH);	close(FH);
	if($upload_photo_form==1)
	{
	resizeImage($filepath.'/'.$file);
	$upload_photo_form = 0;
	}
}	}
if ($parser eq 'parse') {	if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,	my $mm = new File::MMagic;
$codebase);	my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
unless ($parse_result eq 'ok') {	if ($mime_type eq 'text/html') {
&logthis('Failed to parse '.$filepath.$file.	my $parse_result = &extract_embedded_items($filepath.'/'.$file,
' for embedded media: '.$parse_result);	$allfiles,$codebase);
	unless ($parse_result eq 'ok') {
	&logthis('Failed to parse '.$filepath.$file.
	' for embedded media: '.$parse_result);
	}
}	}
}	}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
Line 1927 sub finishuserfileupload {	Line 2335 sub finishuserfileupload {

# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
my $docuhome=&homeserver($docuname,$docudom);	my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);	my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
if ($fetchthumb) {	if ($fetchthumb) {
Line 1948 sub finishuserfileupload {	Line 2356 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 1963 sub extract_embedded_items {	Line 2371 sub extract_embedded_items {
if ($content) {	if ($content) {
$p = HTML::LCParser->new($content);	$p = HTML::LCParser->new($content);
} else {	} else {
$p = HTML::LCParser->new($filepath.'/'.$file);	$p = HTML::LCParser->new($fullpath);
}	}
while (my $t=$p->get_token()) {	while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {	if ($t->[0] eq 'S') {
Line 2059 sub add_filetype {	Line 2467 sub add_filetype {
}	}

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

sub removeuserfile {	sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;	my ($docuname,$docudom,$fname)=@_;
my $home=&homeserver($docuname,$docudom);	my $home=&homeserver($docuname,$docudom);
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);	my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
if ($result eq 'ok') {	if ($result eq 'ok') {
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {	if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
my $metafile = $fname.'.meta';	my $metafile = $fname.'.meta';
my $metaresult = &removeuserfile($docuname,$docudom,$metafile);	my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
my $url = "/uploaded/$docudom/$docuname/$fname";	my $url = "/uploaded/$docudom/$docuname/$fname";
my ($file,$group) = (&parse_portfolio_url($url))[3,4];	my ($file,$group) = (&parse_portfolio_url($url))[3,4];
my $sqlresult =	my $sqlresult =
&update_portfolio_table($docuname,$docudom,$file,	&update_portfolio_table($docuname,$docudom,$file,
'portfolio_metadata',$group,	'portfolio_metadata',$group,
Line 2134 sub flushcourselogs {	Line 2542 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 2147 sub flushcourselogs {	Line 2555 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 2218 sub flushcourselogs {	Line 2624 sub flushcourselogs {
# Reverse lookup of domain roles (dc, ad, li, sc, au)	# Reverse lookup of domain roles (dc, ad, li, sc, au)
#	#
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).
Line 2278 sub courseacclog {	Line 2684 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 2343 sub userrolelog {	Line 2754 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);
	if (($trole ne 'st') \|\| ($sec ne '')) {
	&devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
	}
	}
	}
	return;
	}

sub get_course_adv_roles {	sub get_course_adv_roles {
my $cid=shift;	my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));	$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);	my %coursehash=&coursedescription($cid);
	my $crstype = &Apache::loncommon::course_type($cid);
my %nothide=();	my %nothide=();
foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
$nothide{join(':',split(/[\@\:]/,$user))}=1;	if ($user !~ /:/) {
	$nothide{join(':',split(/[\@]/,$user))}=1;
	} else {
	$nothide{$user}=1;
	}
}	}
my %returnhash=();	my %returnhash=();
my %dumphash=	my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});	&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;	my $now=time;
foreach my $entry (keys %dumphash) {	my %privileged;
	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }	if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$entry);	my ($role,$username,$domain,$section)=split(/\:/,$entry);
if ($username eq '' \|\| $domain eq '') { next; }	if ($username eq '' \|\| $domain eq '') { next; }
if ((&privileged($username,$domain)) &&	unless (ref($privileged{$domain}) eq 'HASH') {
(!$nothide{$username.':'.$domain})) { next; }	my %dompersonnel =
	&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
	$privileged{$domain} = {};
	foreach my $server (keys(%dompersonnel)) {
	if (ref($dompersonnel{$server}) eq 'HASH') {
	foreach my $user (keys(%{$dompersonnel{$server}})) {
	my ($trole,$uname,$udom) = split(/:/,$user);
	$privileged{$udom}{$uname} = 1;
	}
	}
	}
	}
	if ((exists($privileged{$domain}{$username})) &&
	(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }	if ($role eq 'cr') { next; }
my $key=&plaintext($role);	if ($codes) {
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $role .= ':'.$section; }
if ($returnhash{$key}) {	if ($returnhash{$role}) {
$returnhash{$key}.=','.$username.':'.$domain;	$returnhash{$role}.=','.$username.':'.$domain;
	} else {
	$returnhash{$role}=$username.':'.$domain;
	}
} else {	} else {
$returnhash{$key}=$username.':'.$domain;	my $key=&plaintext($role,$crstype);
	if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
	if ($returnhash{$key}) {
	$returnhash{$key}.=','.$username.':'.$domain;
	} else {
	$returnhash{$key}=$username.':'.$domain;
	}
}	}
}	}
return %returnhash;	return %returnhash;
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;	my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }	unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }	unless (defined($udom)) { $udom=$env{'user.domain'}; }
my %dumphash;	my (%dumphash,%nothide);
if ($context eq 'userroles') {	if ($context eq 'userroles') {
%dumphash = &dump('roles',$udom,$uname);	%dumphash = &dump('roles',$udom,$uname);
} else {	} else {
%dumphash=	%dumphash=
&dump('nohist_userroles',$udom,$uname);	&dump('nohist_userroles',$udom,$uname);
	if ($hidepriv) {
	my %coursehash=&coursedescription($udom.'_'.$uname);
	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
	if ($user !~ /:/) {
	$nothide{join(':',split(/[\@]/,$user))} = 1;
	} else {
	$nothide{$user} = 1;
	}
	}
	}
}	}
my %returnhash=();	my %returnhash=();
my $now=time;	my $now=time;
	my %privileged;
foreach my $entry (keys(%dumphash)) {	foreach my $entry (keys(%dumphash)) {
my ($role,$tend,$tstart);	my ($role,$tend,$tstart);
if ($context eq 'userroles') {	if ($context eq 'userroles') {
Line 2398 sub get_my_roles {	Line 2881 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 2427 sub get_my_roles {	Line 2910 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})) {
next;	if ($role =~ /^cr\//) {
	if (!grep(/^cr$/,@{$roles})) {
	next;
	}
	} else {
	next;
	}
	}
	}
	if ($hidepriv) {
	if ($context eq 'userroles') {
	if ((&privileged($username,$domain)) &&
	(!$nothide{$username.':'.$domain})) {
	next;
	}
	} else {
	unless (ref($privileged{$domain}) eq 'HASH') {
	my %dompersonnel =
	&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
	$privileged{$domain} = {};
	if (keys(%dompersonnel)) {
	foreach my $server (keys(%dompersonnel)) {
	if (ref($dompersonnel{$server}) eq 'HASH') {
	foreach my $user (keys(%{$dompersonnel{$server}})) {
	my ($trole,$uname,$udom) = split(/:/,$user);
	$privileged{$udom}{$uname} = $trole;
	}
	}
	}
	}
	}
	if (exists($privileged{$domain}{$username})) {
	if (!$nothide{$username.':'.$domain}) {
	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 2469 sub getannounce {	Line 2992 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,$cloner,$cc_clone,
	$cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
	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.':'.&escape($cloner).':'.
	&escape($cc_clone).':'.$cloneonly.':'.
	&escape($createdbefore).':'.&escape($createdafter).':'.
	&escape($creationcontext),$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 2533 sub dcmaildump {	Line 3109 sub dcmaildump {

sub get_domain_roles {	sub get_domain_roles {
my ($dom,$roles,$startdate,$enddate)=@_;	my ($dom,$roles,$startdate,$enddate)=@_;
if (undef($startdate) \|\| $startdate eq '') {	if ((!defined($startdate)) \|\| ($startdate eq '')) {
$startdate = '.';	$startdate = '.';
}	}
if (undef($enddate) \|\| $enddate eq '') {	if ((!defined($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 2565 sub get_first_access {	Line 3144 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 2578 sub set_first_access {	Line 3159 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 2936 sub tmpreset {	Line 3519 sub tmpreset {
if (tie(%hash,'GDBM_File',	if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',	$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach my $key (keys %hash) {	foreach my $key (keys(%hash)) {
if ($key=~ /:$symb/) {	if ($key=~ /:$symb/) {
delete($hash{$key});	delete($hash{$key});
}	}
Line 3208 sub coursedescription {	Line 3791 sub coursedescription {
}	}
}	}
if (!$args->{'one_time'}) {	if (!$args->{'one_time'}) {
&appenv(%envhash);	&appenv(\%envhash);
}	}
return %returnhash;	return %returnhash;
}	}
Line 3219 sub privileged {	Line 3802 sub privileged {
my ($username,$domain)=@_;	my ($username,$domain)=@_;
my $rolesdump=&reply("dump:$domain:$username:roles",	my $rolesdump=&reply("dump:$domain:$username:roles",
&homeserver($username,$domain));	&homeserver($username,$domain));
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return 0; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '') \|\|
	($rolesdump =~ /^error:/)) {
	return 0;
	}
my $now=time;	my $now=time;
if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach my $entry (split(/&/,$rolesdump)) {	foreach my $entry (split(/&/,$rolesdump)) {
Line 3247 sub privileged {	Line 3833 sub privileged {

sub rolesinit {	sub rolesinit {
my ($domain,$username,$authhost)=@_;	my ($domain,$username,$authhost)=@_;
	my $now=time;
	my %userroles = ('user.login.time' => $now);
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 '') \|\|
	($rolesdump =~ /^error:/)) {
	return \%userroles;
	}
my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();
my $now=time;
my %userroles = ('user.login.time' => $now);
my $group_privs;	my $group_privs;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
Line 3371 sub set_userprivs {	Line 3960 sub set_userprivs {
my $adv=0;	my $adv=0;
my %grouproles = ();	my %grouproles = ();
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;
Line 3393 sub set_userprivs {	Line 3982 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 3414 sub set_userprivs {	Line 4003 sub set_userprivs {
return ($author,$adv);	return ($author,$adv);
}	}

	sub role_status {
	my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
	my @pwhere = ();
	if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
	(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
	unless (!defined($$role) \|\| $$role eq '') {
	$$where=join('.',@pwhere);
	$$trolecode=$$role.'.'.$$where;
	($$tstart,$$tend)=split(/\./,$env{$rolekey});
	$$tstatus='is';
	if ($$tstart && $$tstart>$then) {
	$$tstatus='future';
	if ($$tstart<$now) {
	if ($$tstart && $$tstart>$refresh) {
	if (($$where ne '') && ($$role ne '')) {
	my (%allroles,%allgroups,$group_privs);
	my %userroles = (
	'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
	);
	my $spec=$$role.'.'.$$where;
	my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
	if ($$role eq 'gr') {
	my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
	$env{'user.name'})=@_;
	my ($trole) = split('_',$role,1);
	(undef,my $group_privs) = split(/\//,$trole);
	$group_privs = &unescape($group_privs);
	}
	if ($$role =~ /^cr\//) {
	&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
	} elsif ($$role eq 'gr') {
	my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
	$env{'user.name'});
	my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
	(undef,my $group_privs) = split(/\//,$trole);
	$group_privs = &unescape($group_privs);
	&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
	} else {
	&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
	}
	my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
	&appenv(\%userroles,[$$role,'cm']);
	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
	}
	}
	$$tstatus = 'is';
	}
	}
	if ($$tend) {
	if ($$tend<$then) {
	$$tstatus='expired';
	} elsif ($$tend<$now) {
	$$tstatus='will_not';
	}
	}
	}
	}
	}

	sub check_adhoc_privs {
	my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
	my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
	if ($env{$cckey}) {
	my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
	&role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
	unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {
	&set_adhoc_privileges($cdom,$cnum,$checkrole);
	}
	} else {
	&set_adhoc_privileges($cdom,$cnum,$checkrole);
	}
	}

	sub set_adhoc_privileges {
	# role can be cc or ca
	my ($dcdom,$pickedcourse,$role) = @_;
	my $area = '/'.$dcdom.'/'.$pickedcourse;
	my $spec = $role.'.'.$area;
	my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
	$env{'user.name'});
	my %ccrole = ();
	&standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
	my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
	&appenv(\%userroles,[$role,'cm']);
	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
	&appenv( {'request.role' => $spec,
	'request.role.domain' => $dcdom,
	'request.course.sec' => ''
	}
	);
	my $tadv=0;
	if (&allowed('adv') eq 'F') { $tadv=1; }
	&appenv({'request.role.adv' => $tadv});
	}

# --------------------------------------------------------------- get interface	# --------------------------------------------------------------- get interface

sub get {	sub get {
Line 3449 sub del {	Line 4133 sub del {
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
$items.=&escape($item).'&';	$items.=&escape($item).'&';
}	}

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

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

Line 3757 sub tmpget {	Line 4441 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 4012 sub is_portfolio_file {	Line 4697 sub is_portfolio_file {
return;	return;
}	}

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

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

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

	my ($toolstatus,$inststatus);

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

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

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

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

	sub check_can_request {
	my ($dom,$can_request) = @_;
	my $canreq = 0;
	my ($types,$typename) = &Apache::loncommon::course_types();
	my @options = ('approval','validate','autolimit');
	my $optregex = join('\|',@options);
	if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
	foreach my $type (@{$types}) {
	if (&usertools_access($env{'user.name'},
	$env{'user.domain'},
	$type,undef,'requestcourses')) {
	$canreq ++;
	if ($dom eq $env{'user.domain'}) {
	$can_request->{$type} = 1;
	}
	}
	if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
	my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
	if (@curr > 0) {
	$canreq ++;
	unless ($dom eq $env{'user.domain'}) {
	if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
	$can_request->{$type} = 1;
	}
	}
	}
	}
	}
	}
	return $canreq;
	}

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

Line 4224 sub allowed {	Line 5084 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 4328 sub allowed {	Line 5187 sub allowed {

my $envkey;	my $envkey;
if ($thisallowed=~/L/) {	if ($thisallowed=~/L/) {
foreach $envkey (keys %env) {	foreach $envkey (keys(%env)) {
if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {	if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {
my $courseid=$2;	my $courseid=$2;
my $roleid=$1.'.'.$2;	my $roleid=$1.'.'.$2;
Line 4577 sub log_query {	Line 5436 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 4616 sub fetch_enrollment_query {	Line 5478 sub fetch_enrollment_query {
}	}
my $host=&hostname($homeserver);	my $host=&hostname($homeserver);
my $cmd = '';	my $cmd = '';
foreach my $affiliate (keys %{$affiliatesref}) {	foreach my $affiliate (keys(%{$affiliatesref})) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}	}
$cmd =~ s/%%$//;	$cmd =~ s/%%$//;
Line 4734 sub auto_run {	Line 5596 sub auto_run {
$response = 1;	$response = 1;
}	}
} else {	} else {
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver;
$response = &reply('autorun:'.$cdom,$homeserver);	if (&is_course($cdom,$cnum)) {
	$homeserver = &homeserver($cnum,$cdom);
	} else {
	$homeserver = &domain($cdom,'primary');
	}
	if ($homeserver ne 'no_host') {
	$response = &reply('autorun:'.$cdom,$homeserver);
	}
}	}
return $response;	return $response;
}	}

sub auto_get_sections {	sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;	my ($cnum,$cdom,$inst_coursecode) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver;
my @secs = ();	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));	$homeserver = &homeserver($cnum,$cdom);
unless ($response eq 'refused') {	}
@secs = split(/:/,$response);	if (!defined($homeserver)) {
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	}
	my @secs;
	if (defined($homeserver)) {
	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
	unless ($response eq 'refused') {
	@secs = split(/:/,$response);
	}
}	}
return @secs;	return @secs;
}	}
Line 4765 sub auto_validate_courseID {	Line 5644 sub auto_validate_courseID {
return $response;	return $response;
}	}

	sub auto_validate_instcode {
	my ($cnum,$cdom,$instcode,$owner) = @_;
	my ($homeserver,$response);
	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
	$homeserver = &homeserver($cnum,$cdom);
	}
	if (!defined($homeserver)) {
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	}
	my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
	&escape($instcode).':'.&escape($owner),$homeserver));
	my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
	return ($outcome,$description);
	}

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;	my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);	my ($homeserver,$response);
Line 4879 sub auto_instcode_format {	Line 5775 sub auto_instcode_format {
push(@homeservers,$tryserver);	push(@homeservers,$tryserver);
}	}
}	}
	} elsif ($caller eq 'requests') {
	if ($codedom =~ /^$match_domain$/) {
	my $chome = &domain($codedom,'primary');
	unless ($chome eq 'no_host') {
	push(@homeservers,$chome);
	}
	}
} else {	} else {
push(@homeservers,&homeserver($caller,$codedom));	push(@homeservers,&homeserver($caller,$codedom));
}	}
Line 4936 sub auto_instcode_defaults {	Line 5839 sub auto_instcode_defaults {
}	}

return $response;	return $response;
}	}

	sub auto_possible_instcodes {
	my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
	unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') &&
	(ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
	return;
	}
	my (@homeservers,$uhome);
	if (defined(&domain($domain,'primary'))) {
	$uhome=&domain($domain,'primary');
	push(@homeservers,&domain($domain,'primary'));
	} else {
	my %servers = &get_servers($domain,'library');
	foreach my $tryserver (keys(%servers)) {
	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
	push(@homeservers,$tryserver);
	}
	}
	}
	my $response;
	foreach my $server (@homeservers) {
	$response=&reply('autopossibleinstcodes:'.$domain,$server);
	next if ($response =~ /(con_lost\|error\|no_such_host\|refused)/);
	my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) =
	split(':',$response);
	@{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
	@{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
	foreach my $item (split('&',$cat_title)) {
	my ($name,$value)=split('=',$item);
	$cat_titles->{&unescape($name)}=&thaw_unescape($value);
	}
	foreach my $item (split('&',$cat_order)) {
	my ($name,$value)=split('=',$item);
	$cat_orders->{&unescape($name)}=&thaw_unescape($value);
	}
	return 'ok';
	}
	return $response;
	}

	sub auto_courserequest_checks {
	my ($dom) = @_;
	my ($homeserver,%validations);
	if ($dom =~ /^$match_domain$/) {
	$homeserver = &domain($dom,'primary');
	}
	unless ($homeserver eq 'no_host') {
	my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
	my @items = split(/&/,$response);
	foreach my $item (@items) {
	my ($key,$value) = split('=',$item);
	$validations{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	return %validations;
	}

	sub auto_courserequest_validation {
	my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
	my ($homeserver,$response);
	if ($dom =~ /^$match_domain$/) {
	$homeserver = &domain($dom,'primary');
	}
	unless ($homeserver eq 'no_host') {

	$response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
	':'.&escape($crstype).':'.&escape($inststatuslist).
	':'.&escape($instcode).':'.&escape($instseclist),
	$homeserver));
	}
	return $response;
	}

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 4990 sub toggle_coursegroup_status {	Line 5973 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 5083 sub devalidate_getgroups_cache {	Line 6066 sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text	# ------------------------------------------------------------------ Plain Text

sub plaintext {	sub plaintext {
my ($short,$type,$cid) = @_;	my ($short,$type,$cid,$forcedefault) = @_;
if ($short =~ /^cr/) {	if ($short =~ /^cr/) {
return (split('/',$short))[-1];	return (split('/',$short))[-1];
}	}
if (!defined($cid)) {	if (!defined($cid)) {
$cid = $env{'request.course.id'};	$cid = $env{'request.course.id'};
}	}
if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {	if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) {
return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.	unless ($forcedefault) {
'.plaintext'});	my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};
	&Apache::lonlocal::mt_escape(\$roletext);
	return &Apache::lonlocal::mt($roletext);
	}
}	}
my %rolenames = (	my %rolenames = (
Course => 'std',	Course => 'std',
Group => 'alt1',	Community => 'alt1',
);	);
if (defined($type) &&	if (defined($type) &&
defined($rolenames{$type}) &&	defined($rolenames{$type}) &&
Line 5110 sub plaintext {	Line 6096 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;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {	unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.	my $refused = 1;
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	if ($context eq 'requestcourses') {
$env{'user.name'}.' at '.$env{'user.domain'});	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
return 'refused';	if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
	if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if ($crsenv{'internal.courseowner'} eq
	$env{'user.name'}.':'.$env{'user.domain'}) {
	$refused = '';
	}
	}
	}
	}
	}
	if ($refused) {
	&logthis('Refused custom assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
	' by '.$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
}	}
$mrole='cr';	$mrole='cr';
} elsif ($role =~ /^gr\//) {	} elsif ($role =~ /^gr\//) {
Line 5135 sub assignrole {	Line 6139 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 = '';
	} elsif ($context eq 'requestcourses') {
	my @possroles = ('st','ta','ep','in','cc');
	if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if ($crsenv{'internal.courseowner'} eq
	$env{'user.name'}.':'.$env{'user.domain'}) {
	$refused = '';
	}
	}
	}
	if ($refused) {
	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
	' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
	}
}	}
$mrole=$role;	$mrole=$role;
}	}
Line 5155 sub assignrole {	Line 6184 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 5165 sub assignrole {	Line 6195 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 5173 sub assignrole {	Line 6204 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 5213 sub modifyuser {	Line 6245 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 5274 sub modifyuser {	Line 6306 sub modifyuser {
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
my @tmp=&get('environment',	my @tmp=&get('environment',
['firstname','middlename','lastname','generation','id',	['firstname','middlename','lastname','generation','id',
'permanentemail'],	'permanentemail','inststatus'],
$udom,$uname);	$udom,$uname);
my %names;	my %names;
if ($tmp[0] =~ m/^error:.*/) {	if ($tmp[0] =~ m/^error:.*/) {
Line 5292 sub modifyuser {	Line 6324 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 ($uid) { $names{'id'} = $uid; }
	if (defined($inststatus)) {
	$names{'inststatus'} = '';
	my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
	if (ref($usertypes) eq 'HASH') {
	my @okstatuses;
	foreach my $item (split(/:/,$inststatus)) {
	if (defined($usertypes->{$item})) {
	push(@okstatuses,$item);
	}
	}
	if (@okstatuses) {
	$names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
	}
	}
	}
my $reply = &put('environment', \%names, $udom,$uname);	my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }	if ($reply ne 'ok') { return 'error: '.$reply; }
my $sqlresult = &update_allusers_table($uname,$udom,\%names);	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 5312 sub modifyuser {	Line 6362 sub modifyuser {

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

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
Line 5390 sub modify_student_enrollment {	Line 6441 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 5435 sub writecoursepref {	Line 6486 sub writecoursepref {

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
$course_owner,$crstype)=@_;	$course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	if ($context eq 'requestcourses') {
	my $can_create = 0;
	my ($ownername,$ownerdom) = split(':',$course_owner);
	if ($udom eq $ownerdom) {
	if (&usertools_access($ownername,$ownerdom,$category,undef,
	$context)) {
	$can_create = 1;
	}
	} else {
	my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
	$category);
	if ($userenv{'reqcrsotherdom.'.$category} ne '') {
	my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
	if (@curr > 0) {
	my @options = qw(approval validate autolimit);
	my $optregex = join('\|',@options);
	if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
	$can_create = 1;
	}
	}
	}
	}
	if ($can_create) {
	unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
	unless (&allowed('ccc',$udom)) {
	return 'refused';
	}
	}
	} else {
	return 'refused';
	}
	} elsif (!&allowed('ccc',$udom)) {
return 'refused';	return 'refused';
}	}
# ------------------------------------------------------------------- Create ID	# --------------------------------------------------------------- Get Unique ID
my $uname=int(1+rand(9)).	my $uname;
('a'..'z','A'..'Z','0'..'9')[int(rand(62))].	if ($cnum =~ /^$match_courseid$/) {
substr($$.time,0,5).unpack("H8",pack("I32",time)).	my $chome=&homeserver($cnum,$udom,'true');
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	if (($chome eq '') \|\| ($chome eq 'no_host')) {
# ----------------------------------------------- Make sure that does not exist	$uname = $cnum;
my $uhome=&homeserver($uname,$udom,'true');	} else {
unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {	$uname = &generate_coursenum($udom);
$uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).	}
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	} else {
$uhome=&homeserver($uname,$udom,'true');	$uname = &generate_coursenum($udom);
unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {	}
return 'error: unable to generate unique course-ID';	return $uname if ($uname =~ /^error/);
}	# -------------------------------------------------- Check supplied server name
}
# ------------------------------------------------ Check supplied server name
$course_server = $env{'user.homeserver'} if (! defined($course_server));	$course_server = $env{'user.homeserver'} if (! defined($course_server));
if (! &is_library($course_server)) {	if (! &is_library($course_server)) {
return 'error:bad server name '.$course_server;	return 'error:bad server name '.$course_server;
Line 5465 sub createcourse {	Line 6545 sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',	my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$course_server);	$course_server);
unless ($reply eq 'ok') { return 'error: '.$reply; }	unless ($reply eq 'ok') { return 'error: '.$reply; }
$uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
return 'error: no such course';	return 'error: no such course';
}	}
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).	my $now = time;
':'.&escape($inst_code).':'.&escape($course_owner).':'.	my $newcourse = {
&escape($crstype),$uhome);	$udom.'_'.$uname => {
&flushcourselogs();	description => $description,
	inst_code => $inst_code,
	owner => $course_owner,
	type => $crstype,
	creator => $env{'user.name'}.':'.
	$env{'user.domain'},
	created => $now,
	context => $context,
	},
	};
	&courseidput($udom,$newcourse,$uhome,'notime');
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
unless ($nonstandard) {	unless ($nonstandard) {
Line 5501 ENDINITMAP	Line 6591 ENDINITMAP
return '/'.$udom.'/'.$uname;	return '/'.$udom.'/'.$uname;
}	}

	# ------------------------------------------------------------------- Create ID
	sub generate_coursenum {
	my ($udom) = @_;
	my $domdesc = &domain($udom);
	return 'error: invalid domain' if ($domdesc eq '');
	my $uname=int(1+rand(9)).
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	# ----------------------------------------------- Make sure that does not exist
	my $uhome=&homeserver($uname,$udom,'true');
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	$uname=int(1+rand(9)).
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	$uhome=&homeserver($uname,$udom,'true');
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	return 'error: unable to generate unique course-ID';
	}
	}
	return $uname;
	}

sub is_course {	sub is_course {
my ($cdom,$cnum) = @_;	my ($cdom,$cnum) = @_;
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,	my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
Line 5511 sub is_course {	Line 6625 sub is_course {
return 0;	return 0;
}	}

	sub store_userdata {
	my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
	my $result;
	if ($datakey ne '') {
	if (ref($storehash) eq 'HASH') {
	if ($udom eq '' \|\| $uname eq '') {
	$udom = $env{'user.domain'};
	$uname = $env{'user.name'};
	}
	my $uhome=&homeserver($uname,$udom);
	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	$result = 'error: no_host';
	} else {
	$storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
	$storehash->{'host'} = $perlvar{'lonHostID'};

	my $namevalue='';
	foreach my $key (keys(%{$storehash})) {
	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
	}
	$namevalue=~s/\&$//;
	$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
	"$namespace:$datakey:$namevalue",$uhome);
	}
	} else {
	$result = 'error: data to store was not a hash reference';
	}
	} else {
	$result= 'error: invalid requestkey';
	}
	return $result;
	}

# ---------------------------------------------------------- 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 5781 sub modify_access_controls {	Line 6936 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 5957 sub unmark_as_readonly {	Line 7110 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 5989 sub dirlist {	Line 7161 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 6022 sub dirlist {	Line 7199 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 6038 sub dirlist {	Line 7215 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 6068 sub stat_file {	Line 7235 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 6085 sub stat_file {	Line 7251 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 6119 sub directcondval {	Line 7288 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 6276 sub resdata {	Line 7445 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 6305 sub EXT_cache_status {	Line 7474 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 6489 sub EXT {	Line 7658 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 6517 sub EXT {	Line 7689 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 6530 sub EXT {	Line 7702 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 6549 sub EXT {	Line 7722 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 6584 sub EXT {	Line 7756 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 6685 sub metadata {	Line 7869 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 6707 sub metadata {	Line 7894 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 6717 sub metadata {	Line 7905 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 6884 sub metadata {	Line 8078 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 6953 sub devalidate_title_cache {	Line 8147 sub devalidate_title_cache {
&devalidate_cache_new('title',$key);	&devalidate_cache_new('title',$key);
}	}

	# ------------------------------------------------- Get the title of a course

	sub current_course_title {
	return $env{ 'course.' . $env{'request.course.id'} . '.description' };
	}
# ------------------------------------------------- Get the title of a resource	# ------------------------------------------------- Get the title of a resource

sub gettitle {	sub gettitle {
Line 7019 sub symblist {	Line 8218 sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {	if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach my $url (keys %newhash) {	foreach my $url (keys(%newhash)) {
next if ($url eq 'last_known'	next if ($url eq 'last_known'
&& $env{'form.no_update_last_known'});	&& $env{'form.no_update_last_known'});
$hash{declutter($url)}=&encode_symb($mapname,	$hash{declutter($url)}=&encode_symb($mapname,
Line 7056 sub symbverify {	Line 8255 sub symbverify {

if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
	if (($thisurl =~ m{^/adm/wrapper/ext/}) \|\| ($thisurl =~ m{^ext/})) {
	$thisurl =~ s/\?.+$//;
	}
my $ids=$bighash{'ids_'.&clutter($thisurl)};	my $ids=$bighash{'ids_'.&clutter($thisurl)};
unless ($ids) {	unless ($ids) {
$ids=$bighash{'ids_/'.$thisurl};	$ids=$bighash{'ids_/'.$thisurl};
Line 7064 sub symbverify {	Line 8266 sub symbverify {
# ------------------------------------------------------------------- Has ID(s)	# ------------------------------------------------------------------- Has ID(s)
foreach my $id (split(/\,/,$ids)) {	foreach my $id (split(/\,/,$ids)) {
my ($mapid,$resid)=split(/\./,$id);	my ($mapid,$resid)=split(/\./,$id);
	if ($thisfn =~ m{^/adm/wrapper/ext/}) {
	$symb =~ s/\?.+$//;
	}
if (	if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)	&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {	eq $symb) {
Line 7182 sub symbread {	Line 8387 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 7234 sub symbread {	Line 8439 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 7726 sub repcopy_userfile {	Line 8931 sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }	if (-e $transferfile) { return 'ok'; }
my $request;	my $request;
$uri=~s/^\///;	$uri=~s/^\///;
$request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);	my $homeserver = &homeserver($cnum,$cdom);
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
	$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);	my $response=$ua->request($request,$transferfile);
# did it work?	# did it work?
if ($response->is_error()) {	if ($response->is_error()) {
Line 7741 sub repcopy_userfile {	Line 8949 sub repcopy_userfile {

sub tokenwrapper {	sub tokenwrapper {
my $uri=shift;	my $uri=shift;
$uri=~s\|^http\://([^/]+)\|\|;	$uri=~s\|^https?\://([^/]+)\|\|;
$uri=~s\|^/\|\|;	$uri=~s\|^/\|\|;
$env{'user.environment'}=~/\/([^\/]+)\.id/;	$env{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;	my $token=$1;
my (undef,$udom,$uname,$file)=split('/',$uri,4);	my (undef,$udom,$uname,$file)=split('/',$uri,4);
if ($udom && $uname && $file) {	if ($udom && $uname && $file) {
$file=~s\|(\?\.)$\|\|;	$file=~s\|(\?\.)$\|\|;
&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});	&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.	my $homeserver = &homeserver($uname,$udom);
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
	return $protocol.'://'.&hostname($homeserver).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
} else {	} else {
Line 7764 sub tokenwrapper {	Line 8975 sub tokenwrapper {
sub getuploaded {	sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;	$uri=~s/^\///;
$uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;	my $homeserver = &homeserver($cnum,$cdom);
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
	$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=$ua->request($request);
Line 7806 sub filelocation {	Line 9020 sub filelocation {
} elsif ($file=~m{^/home/$match_username/public_html/}) {	} elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference	# is a correct contruction space reference
$location = $file;	$location = $file;
	} elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
	$location = $file;
} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file	} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=	my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);	($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
Line 7814 sub filelocation {	Line 9030 sub filelocation {
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {	if ($is_me) {
$location=&propath($udom,$uname).	$location=&propath($udom,$uname).'/userfiles/'.$filename;
'/userfiles/'.$filename;
} else {	} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;	$udom.'/'.$uname.'/'.$filename;
Line 7832 sub filelocation {	Line 9047 sub filelocation {
}	}
}	}
$location=~s://+:/:g; # remove duplicate /	$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m{/\.\./}) {
	if ($location =~ m{/[^/]+/\.\./}) {
	$location=~ s{/[^/]+/\.\./}{/}g;
	} else {
	$location=~ s{/\.\./}{/}g;
	}
	} #remove dir/..
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;	return $location;
}	}

sub hreflocation {	sub hreflocation {
my ($dir,$file)=@_;	my ($dir,$file)=@_;
unless (($file=~m-^http://-i) \|\| ($file=~m-^/-)) {	unless (($file=~m-^https?\://-i) \|\| ($file=~m-^/-)) {
$file=filelocation($dir,$file);	$file=filelocation($dir,$file);
} elsif ($file=~m-^/adm/-) {	} elsif ($file=~m-^/adm/-) {
$file=~s-^/adm/wrapper/-/-;	$file=~s-^/adm/wrapper/-/-;
Line 7924 sub declutter {	Line 9145 sub declutter {
$thisfn=~s\|^adm/wrapper/\|\|;	$thisfn=~s\|^adm/wrapper/\|\|;
$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;	$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;	unless (($thisfn =~ /^ext/) \|\| ($thisfn =~ /\.(page\|sequence)___\d+___ext/)) {
	$thisfn=~s/\?.+$//;
	}
return $thisfn;	return $thisfn;
}	}

Line 7936 sub clutter {	Line 9159 sub clutter {
\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {	\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
if ($thisfn !~m\|/adm\|) {	if ($thisfn !~m\|^/adm\|) {
if ($thisfn =~ m\|/ext/\|) {	if ($thisfn =~ m\|^/ext/\|) {
$thisfn='/adm/wrapper'.$thisfn;	$thisfn='/adm/wrapper'.$thisfn;
} else {	} else {
my ($ext) = ($thisfn =~ /\.(\w+)$/);	my ($ext) = ($thisfn =~ /\.(\w+)$/);
Line 8035 sub get_dns {	Line 9258 sub get_dns {
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
foreach my $dns (<$config>) {	foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);	next if ($dns !~ /^\^(\S*)/x);
$alldns{$1} = 1;	my $line = $1;
	my ($host,$protocol) = split(/:/,$line);
	if ($protocol ne 'https') {
	$protocol = 'http';
	}
	$alldns{$host} = $protocol;
}	}
while (%alldns) {	while (%alldns) {
my ($dns) = keys(%alldns);	my ($dns) = keys(%alldns);
delete($alldns{$dns});
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"http://$dns$url");	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);	my $response=$ua->request($request);
	delete($alldns{$dns});
next if ($response->is_error());	next if ($response->is_error());
my @content = split("\n",$response->content);	my @content = split("\n",$response->content);
&Apache::lonnet::do_cache_new('dns',$url,\@content,302460*60);	&Apache::lonnet::do_cache_new('dns',$url,\@content,302460*60);
Line 8107 sub get_dns {	Line 9335 sub get_dns {
}	}
return $domain{$name}{$what};	return $domain{$name}{$what};
}	}

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

}	}


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

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

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

Line 8316 sub get_dns {	Line 9564 sub get_dns {

return %iphost;	return %iphost;
}	}

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

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

}	}

BEGIN {	BEGIN {
Line 8405 $memcache=new Cache::Memcached({'servers	Line 9678 $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 8572 when the connection is brought back up	Line 9846 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 8587 that was requested	Line 9861 that was requested

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

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

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

Line 8693 and course level	Line 9971 and course level

=item *	=item *

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

=item *	=item *

get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :	get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
All arguments are optional. Returns a hash of a roles, either for	All arguments are optional. Returns a hash of a roles, either for
co-author/assistant author roles for a user's Construction Space	co-author/assistant author roles for a user's Construction Space
(default), or if $context is 'userroles', 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 8719 provided for types, will default to retu	Line 10003 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 8736 modifyuserauth($udom,$uname,$umode,$upas	Line 10020 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 8755 Inputs:	Line 10040 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 8783 Inputs:	Line 10068 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 8816 Inputs:	Line 10115 Inputs:

=item $start	=item $start

	=item $type

	=item $locktype

	=item $cid

	=item $selfenroll

	=item $context

=back	=back


Line 8874 database) for a course	Line 10183 database) for a course

=item *	=item *

createcourse($udom,$description,$url) : make/modify course	createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course

	=item *

	generate_coursenum($udom) : get a unique (unused) course number in domain $udom

=back	=back

Line 9124 Returns:	Line 10437 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 9152 put_dom($namespace,$storehash,$udom,$uho	Line 10465 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 9166 dirlist($uri) : return directory list ba	Line 10491 dirlist($uri) : return directory list ba

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


	=item *

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

=back	=back


=head2 Apache Request	=head2 Apache Request

=over 4	=over 4

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

Removed from v.1.914
changed lines
	Added in v.1.1035