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.845 and 1.953

version 1.845, 2007/03/08 01:54:50	version 1.953, 2008/03/28 14:52:57
Line 31 package Apache::lonnet;	Line 31 package Apache::lonnet;

use strict;	use strict;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Headers;
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	# use Date::Parse;
use vars	use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
qw(%perlvar %badServerCache %iphost %spareid	$_64bit %env);
%pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount	my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf	%userrolehash, $processmarker, $dumpcount, %coursedombuf,
%domaindescription %domain_auth_def %domain_auth_arg_def	%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary	%courseownerbuf, %coursetypebuf);
$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use HTML::LCParser;	use HTML::LCParser;
use HTML::Parser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);	use Storable qw(thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );	use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;	use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
Line 146 sub logperm {	Line 143 sub logperm {
return 1;	return 1;
}	}

	sub create_connection {
	my ($hostname,$lonid) = @_;
	my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'},
	Type => SOCK_STREAM,
	Timeout => 10);
	return 0 if (!$client);
	print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
	my $result = <$client>;
	chomp($result);
	return 1 if ($result eq 'done');
	return 0;
	}


# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
Line 170 sub subreply {	Line 181 sub subreply {
$client=IO::Socket::UNIX->new(Peer =>"$peerfile",	$client=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10);	Timeout => 10);
if($client) {	if ($client) {
last; # Connected!	last; # Connected!
	} else {
	&create_connection(&hostname($server),$server);
}	}
sleep(1); # Try again later if failed connection.	sleep(1); # Try again later if failed connection.
}	}
my $answer;	my $answer;
if ($client) {	if ($client) {
Line 201 sub reply {	Line 214 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

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

&logthis("Trying to reconnect lonc");	&logthis("Trying to reconnect lonc");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {	if (open(my $fh,"<$loncfile")) {
Line 289 sub convert_and_load_session_env {	Line 320 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 328 sub transfer_profile_to_env {	Line 362 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 360 sub transfer_profile_to_env {	Line 397 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 383 sub timed_flock {	Line 448 sub timed_flock {
# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment

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

# ------------------------------------------ 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 454 sub userload {	Line 532 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 551 sub compare_server_load {	Line 630 sub compare_server_load {
}	}
return ($spare_server,$lowest_load);	return ($spare_server,$lowest_load);
}	}

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

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

	return 0;
	}

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

sub changepass {	sub changepass {
Line 605 sub queryauthenticate {	Line 705 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 720 sub idput {	Line 834 sub idput {
# ------------------------------------------- get items from domain db files	# ------------------------------------------- get items from domain db files

sub get_dom {	sub get_dom {
my ($namespace,$storearr,$udom)=@_;	my ($namespace,$storearr,$udom,$uhome)=@_;
my $items='';	my $items='';
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
$items.=&escape($item).'&';	$items.=&escape($item).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if (!$udom) { $udom=$env{'user.domain'}; }	if (!$udom) {
if (exists($domain_primary{$udom})) {	$udom=$env{'user.domain'};
my $uhome=$domain_primary{$udom};	if (defined(&domain($udom,'primary'))) {
	$uhome=&domain($udom,'primary');
	} else {
	undef($uhome);
	}
	} else {
	if (!$uhome) {
	if (defined(&domain($udom,'primary'))) {
	$uhome=&domain($udom,'primary');
	}
	}
	}
	if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);	my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
	my %returnhash;
	if ($rep eq '' \|\| $rep =~ /^error: 2 /) {
	return %returnhash;
	}
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost\|error\|no_such_host)/i) {	if ( $#pairs==0 && $pairs[0] =~ /^(con_lost\|error\|no_such_host)/i) {
return @pairs;	return @pairs;
}	}
my %returnhash=();
my $i=0;	my $i=0;
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
$returnhash{$item}=&thaw_unescape($pairs[$i]);	$returnhash{$item}=&thaw_unescape($pairs[$i]);
Line 742 sub get_dom {	Line 871 sub get_dom {
}	}
return %returnhash;	return %returnhash;
} else {	} else {
&logthis("get_dom failed - no primary domain server for $udom");	&logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
}	}
}	}

# -------------------------------------------- put items in domain db files	# -------------------------------------------- put items in domain db files

sub put_dom {	sub put_dom {
my ($namespace,$storehash,$udom)=@_;	my ($namespace,$storehash,$udom,$uhome)=@_;
if (!$udom) { $udom=$env{'user.domain'}; }	if (!$udom) {
if (exists($domain_primary{$udom})) {	$udom=$env{'user.domain'};
my $uhome=$domain_primary{$udom};	if (defined(&domain($udom,'primary'))) {
	$uhome=&domain($udom,'primary');
	} else {
	undef($uhome);
	}
	} else {
	if (!$uhome) {
	if (defined(&domain($udom,'primary'))) {
	$uhome=&domain($udom,'primary');
	}
	}
	}
	if ($udom && $uhome && ($uhome ne 'no_host')) {
my $items='';	my $items='';
foreach my $item (keys(%$storehash)) {	foreach my $item (keys(%$storehash)) {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
Line 760 sub put_dom {	Line 901 sub put_dom {
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("putdom:$udom:$namespace:$items",$uhome);	return &reply("putdom:$udom:$namespace:$items",$uhome);
} else {	} else {
&logthis("put_dom failed - no primary domain server for $udom");	&logthis("put_dom failed - no homeserver and/or domain");
}	}
}	}

sub retrieve_inst_usertypes {	sub retrieve_inst_usertypes {
my ($udom) = @_;	my ($udom) = @_;
my (%returnhash,@order);	my (%returnhash,@order);
if (exists($domain_primary{$udom})) {	if (defined(&domain($udom,'primary'))) {
my $uhome=$domain_primary{$udom};	my $uhome=&domain($udom,'primary');
my $rep=&reply("inst_usertypes:$udom",$uhome);	my $rep=&reply("inst_usertypes:$udom",$uhome);
my ($hashitems,$orderitems) = split(/:/,$rep);	my ($hashitems,$orderitems) = split(/:/,$rep);
my @pairs=split(/\&/,$hashitems);	my @pairs=split(/\&/,$hashitems);
Line 788 sub retrieve_inst_usertypes {	Line 929 sub retrieve_inst_usertypes {
return (\%returnhash,\@order);	return (\%returnhash,\@order);
}	}

	sub is_domainimage {
	my ($url) = @_;
	if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img\|logo\|domlogo)/+-) {
	if (&domain($1) ne '') {
	return '1';
	}
	}
	return;
	}

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

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

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

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

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

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

	# ------------------------- Get Authentication and Language Defaults for Domain

	sub get_domain_defaults {
	my ($domain) = @_;
	my $cachetime = 606024;
	my ($defauthtype,$defautharg,$deflang);
	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'],$domain);
	if (ref($domconfig{'defaults'}) eq 'HASH') {
	$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
	$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
	$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
	} else {
	$domdefaults{'lang_def'} = &domain($domain,'lang_def');
	$domdefaults{'auth_def'} = &domain($domain,'auth_def');
	$domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
	}
	&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 820 sub assign_access_key {	Line 1209 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 1012 my %remembered;	Line 1401 my %remembered;
my %accessed;	my %accessed;
my $kicks=0;	my $kicks=0;
my $hits=0;	my $hits=0;
	sub make_key {
	my ($name,$id) = @_;
	if (length($id) > 65
	&& length(&escape($id)) > 200) {
	$id=length($id).':'.&Digest::MD5::md5_hex($id);
	}
	return &escape($name.':'.$id);
	}

sub devalidate_cache_new {	sub devalidate_cache_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }	if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
$memcache->delete($id);	$memcache->delete($id);
delete($remembered{$id});	delete($remembered{$id});
delete($accessed{$id});	delete($accessed{$id});
Line 1023 sub devalidate_cache_new {	Line 1421 sub devalidate_cache_new {

sub is_cached_new {	sub is_cached_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
if (exists($remembered{$id})) {	if (exists($remembered{$id})) {
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
$accessed{$id}=[&gettimeofday()];	$accessed{$id}=[&gettimeofday()];
Line 1046 sub is_cached_new {	Line 1444 sub is_cached_new {

sub do_cache_new {	sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;	my ($name,$id,$value,$time,$debug) = @_;
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
my $setvalue=$value;	my $setvalue=$value;
if (!defined($setvalue)) {	if (!defined($setvalue)) {
$setvalue='__undef__';	$setvalue='__undef__';
Line 1055 sub do_cache_new {	Line 1453 sub do_cache_new {
$time=600;	$time=600;
}	}
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }	if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
$memcache->set($id,$setvalue,$time);	my $result = $memcache->set($id,$setvalue,$time);
	if (! $result) {
	&logthis("caching of id -> $id failed");
	$memcache->disconnect_all();
	}
# need to make a copy of $value	# need to make a copy of $value
#&make_room($id,$value,$debug);	&make_room($id,$value,$debug);
return $value;	return $value;
}	}

sub make_room {	sub make_room {
my ($id,$value,$debug)=@_;	my ($id,$value,$debug)=@_;
$remembered{$id}=$value;
	$remembered{$id}= (ref($value)) ? &Storable::dclone($value)
	: $value;
if ($to_remember<0) { return; }	if ($to_remember<0) { return; }
$accessed{$id}=[&gettimeofday()];	$accessed{$id}=[&gettimeofday()];
if (scalar(keys(%remembered)) <= $to_remember) { return; }	if (scalar(keys(%remembered)) <= $to_remember) { return; }
Line 1289 sub ssi_body {	Line 1693 sub ssi_body {
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {	if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
$form{'LONCAPA_INTERNAL_no_discussion'}='true';	$form{'LONCAPA_INTERNAL_no_discussion'}='true';
}	}
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output='';
&ssi($filelink,%form));	my $response;
	if ($filelink=~/^http\:/) {
	$output=&externalssi($filelink);
	} else {
	($output,$response)=&ssi($filelink,%form);
	}
$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;	$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;
$output=~s/^.?\<body[^\>]\>//si;	$output=~s/^.?\<body[^\>]\>//si;
$output=~s/(.)\<\/body\s\>.*?$/$1/si;	$output=~s/\<\/body\s\>.?$//si;
return $output;	if (wantarray) {
	return ($output, $response);
	} else {
	return $output;
	}
}	}

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

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

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

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

my $request;	my $request;

$form{'no_update_last_known'}=1;	$form{'no_update_last_known'}=1;
	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);	$request=new HTTP::Request('POST',&absolute_url().$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));	$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
Line 1328 sub ssi {	Line 1749 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 1349 sub allowuploaded {	Line 1774 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 1496 sub clean_filename {	Line 1921 sub clean_filename {
# $coursedoc - if true up to the current course	# $coursedoc - if true up to the current course
# if false	# if false
# $subdir - directory in userfile to store the file into	# $subdir - directory in userfile to store the file into
# $parser, $allfiles, $codebase - unknown	# $parser - instruction to parse file for objects ($parser = parse)
#	# $allfiles - reference to hash for embedded objects
	# $codebase - reference to hash for codebase of java objects
	# $desuname - username for permanent storage of uploaded file
	# $dsetudom - domain for permanaent storage of uploaded file
	# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
	# $thumbheight - height (pixels) of thumbnail to make for uploaded image
	#
# output: url of file in userspace, or error: <message>	# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse	# or /adm/notfound.html if failure to upload occurse


sub userfileupload {	sub userfileupload {
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;	my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
	$destudom,$thumbwidth,$thumbheight)=@_;
if (!defined($subdir)) { $subdir='unknown'; }	if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};	my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);	$fname=&clean_filename($fname);
Line 1550 sub userfileupload {	Line 1982 sub userfileupload {
if ($env{'form.folder'} =~ m/^(default\|supplemental)/) {	if ($env{'form.folder'} =~ m/^(default\|supplemental)/) {
return &finishuserfileupload($docuname,$docudom,	return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,	$formname,$fname,$parser,$allfiles,
$codebase);	$codebase,$thumbwidth,$thumbheight);
} else {	} else {
$fname=$env{'form.folder'}.'/'.$fname;	$fname=$env{'form.folder'}.'/'.$fname;
return &process_coursefile('uploaddoc',$docuname,$docudom,	return &process_coursefile('uploaddoc',$docuname,$docudom,
Line 1560 sub userfileupload {	Line 1992 sub userfileupload {
} elsif (defined($destuname)) {	} elsif (defined($destuname)) {
my $docuname=$destuname;	my $docuname=$destuname;
my $docudom=$destudom;	my $docudom=$destudom;
return &finishuserfileupload($docuname,$docudom,$formname,	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$fname,$parser,$allfiles,$codebase);	$parser,$allfiles,$codebase,
	$thumbwidth,$thumbheight);

} else {	} else {
my $docuname=$env{'user.name'};	my $docuname=$env{'user.name'};
Line 1570 sub userfileupload {	Line 2003 sub userfileupload {
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};	$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};	$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
}	}
return &finishuserfileupload($docuname,$docudom,$formname,	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$fname,$parser,$allfiles,$codebase);	$parser,$allfiles,$codebase,
	$thumbwidth,$thumbheight);
}	}
}	}

sub finishuserfileupload {	sub finishuserfileupload {
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;	my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
	$thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';	my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};	my $filepath=$perlvar{'lonDocRoot'};
my ($fnamepath,$file);	my ($fnamepath,$file,$fetchthumb);
$file=$fname;	$file=$fname;
if ($fname=~m\|/\|) {	if ($fname=~m\|/\|) {
($fnamepath,$file) = ($fname =~ m\|^(.*)/([^/]+)$\|);	($fnamepath,$file) = ($fname =~ m\|^(.*)/([^/]+)$\|);
Line 1615 sub finishuserfileupload {	Line 2050 sub finishuserfileupload {
' for embedded media: '.$parse_result);	' for embedded media: '.$parse_result);
}	}
}	}
	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
	my $input = $filepath.'/'.$file;
	my $output = $filepath.'/'.'tn-'.$file;
	my $thumbsize = $thumbwidth.'x'.$thumbheight;
	system("convert -sample $thumbsize $input $output");
	if (-e $filepath.'/'.'tn-'.$file) {
	$fetchthumb = 1;
	}
	}

# 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) {
	my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
	if ($thumbresult ne 'ok') {
	&logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
	$docuhome.': '.$thumbresult);
	}
	}
#	#
# Return the URL to it	# Return the URL to it
return '/uploaded/'.$path.$file;	return '/uploaded/'.$path.$file;
Line 1627 sub finishuserfileupload {	Line 2079 sub finishuserfileupload {
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.	&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
': '.$fetchresult);	': '.$fetchresult);
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

sub extract_embedded_items {	sub extract_embedded_items {
Line 1651 sub extract_embedded_items {	Line 2103 sub extract_embedded_items {
while (my $t=$p->get_token()) {	while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {	if ($t->[0] eq 'S') {
my ($tagname, $attr) = ($t->[1],$t->[2]);	my ($tagname, $attr) = ($t->[1],$t->[2]);
push (@state, $tagname);	push(@state, $tagname);
if (lc($tagname) eq 'allow') {	if (lc($tagname) eq 'allow') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
if (lc($tagname) eq 'img') {	if (lc($tagname) eq 'img') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
	if (lc($tagname) eq 'a') {
	&add_filetype($allfiles,$attr->{'href'},'href');
	}
if (lc($tagname) eq 'script') {	if (lc($tagname) eq 'script') {
if ($attr->{'archive'} =~ /\.jar$/i) {	if ($attr->{'archive'} =~ /\.jar$/i) {
&add_filetype($allfiles,$attr->{'archive'},'archive');	&add_filetype($allfiles,$attr->{'archive'},'archive');
Line 1814 sub flushcourselogs {	Line 2269 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 1827 sub flushcourselogs {	Line 2282 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 1899 sub flushcourselogs {	Line 2352 sub flushcourselogs {
#	#
my %domrolebuffer = ();	my %domrolebuffer = ();
foreach my $entry (keys %domainrolehash) {	foreach my $entry (keys %domainrolehash) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;	my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
if ($domrolebuffer{$rudom}) {	if ($domrolebuffer{$rudom}) {
$domrolebuffer{$rudom}.='&'.&escape($entry).	$domrolebuffer{$rudom}.='&'.&escape($entry).
'='.&escape($domainrolehash{$entry});	'='.&escape($domainrolehash{$entry});
Line 2004 sub userrolelog {	Line 2457 sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;	=$tend.':'.$tstart;
}	}
	if (($env{'request.role'} =~ /dc\./) &&
	(($trole=~/^au/) \|\| ($trole=~/^in/) \|\|
	($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|
	($trole=~/^cr/) \|\| ($trole=~/^ta/))) {
	$userrolehash
	{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
	=$tend.':'.$tstart;
	}
if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|	if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|
($trole=~/^li/) \|\| ($trole=~/^li/) \|\|	($trole=~/^li/) \|\| ($trole=~/^li/) \|\|
($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|	($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|
Line 2016 sub userrolelog {	Line 2477 sub userrolelog {
}	}

sub get_course_adv_roles {	sub get_course_adv_roles {
my $cid=shift;	my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));	$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);	my %coursehash=&coursedescription($cid);
my %nothide=();	my %nothide=();
foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
$nothide{join(':',split(/[\@\:]/,$user))}=1;	if ($user !~ /:/) {
	$nothide{join(':',split(/[\@]/,$user))}=1;
	} else {
	$nothide{$user}=1;
	}
}	}
my %returnhash=();	my %returnhash=();
my %dumphash=	my %dumphash=
Line 2037 sub get_course_adv_roles {	Line 2502 sub get_course_adv_roles {
if ((&privileged($username,$domain)) &&	if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }	(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }	if ($role eq 'cr') { next; }
my $key=&plaintext($role);	if ($codes) {
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $role .= ':'.$section; }
if ($returnhash{$key}) {	if ($returnhash{$role}) {
$returnhash{$key}.=','.$username.':'.$domain;	$returnhash{$role}.=','.$username.':'.$domain;
	} else {
	$returnhash{$role}=$username.':'.$domain;
	}
} else {	} else {
$returnhash{$key}=$username.':'.$domain;	my $key=&plaintext($role);
	if ($section) { $key.=' (Section '.$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,$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') {
	%dumphash = &dump('roles',$udom,$uname);
	} else {
	%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;
foreach my $entry (keys(%dumphash)) {	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});	my ($role,$tend,$tstart);
	if ($context eq 'userroles') {
	($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
	} else {
	($tend,$tstart)=split(/\:/,$dumphash{$entry});
	}
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 2075 sub get_my_roles {	Line 2569 sub get_my_roles {
next;	next;
}	}
}	}
my ($role,$username,$domain,$section)=split(/\:/,$entry);	my ($rolecode,$username,$domain,$section,$area);
	if ($context eq 'userroles') {
	($area,$rolecode) = split(/_/,$entry);
	(undef,$domain,$username,$section) = split(/\//,$area);
	} else {
	($role,$username,$domain,$section) = split(/\:/,$entry);
	}
if (ref($roledoms) eq 'ARRAY') {	if (ref($roledoms) eq 'ARRAY') {
if (!grep(/^\Q$domain\E$/,@{$roledoms})) {	if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
next;	next;
Line 2083 sub get_my_roles {	Line 2583 sub get_my_roles {
}	}
if (ref($roles) eq 'ARRAY') {	if (ref($roles) eq 'ARRAY') {
if (!grep(/^\Q$role\E$/,@{$roles})) {	if (!grep(/^\Q$role\E$/,@{$roles})) {
	if ($role =~ /^cr\//) {
	if (!grep(/^cr$/,@{$roles})) {
	next;
	}
	} else {
	next;
	}
	}
	}
	if ($hidepriv) {
	if ((&privileged($username,$domain)) &&
	(!$nothide{$username.':'.$domain})) {
next;	next;
}	}
}	}
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	if ($withsec) {
	$returnhash{$username.':'.$domain.':'.$role.':'.$section} =
	$tstart.':'.$tend;
	} else {
	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
	}
}	}
return %returnhash;	return %returnhash;
}	}
Line 2125 sub getannounce {	Line 2642 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)=@_;
	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),$tryserver);
$returnhash{&unescape($key)}=$value;	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 2170 sub dcmailput {	Line 2735 sub dcmailput {
sub dcmaildump {	sub dcmaildump {
my ($dom,$startdate,$enddate,$senders) = @_;	my ($dom,$startdate,$enddate,$senders) = @_;
my %returnhash=();	my %returnhash=();
if (exists($domain_primary{$dom})) {
	if (defined(&domain($dom,'primary'))) {
my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.	my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
&escape($enddate).':';	&escape($enddate).':';
my @esc_senders=map { &escape($_)} @$senders;	my @esc_senders=map { &escape($_)} @$senders;
$cmd.=&escape(join('&',@esc_senders));	$cmd.=&escape(join('&',@esc_senders));
foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {	foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
my ($key,$value) = split(/\=/,$line,2);	my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {	if (($key) && ($value)) {
$returnhash{&unescape($key)} = &unescape($value);	$returnhash{&unescape($key)} = &unescape($value);
Line 2194 sub get_domain_roles {	Line 2760 sub get_domain_roles {
if (undef($enddate) \|\| $enddate eq '') {	if (undef($enddate) \|\| $enddate eq '') {
$enddate = '.';	$enddate = '.';
}	}
my $rolelist = join(':',@{$roles});	my $rolelist;
	if (ref($roles) eq 'ARRAY') {
	$rolelist = join(':',@{$roles});
	}
my %personnel = ();	my %personnel = ();

my %servers = &get_servers($dom,'library');	my %servers = &get_servers($dom,'library');
Line 2220 sub get_first_access {	Line 2789 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 2233 sub set_first_access {	Line 2804 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 2863 sub coursedescription {	Line 3436 sub coursedescription {
}	}
}	}
if (!$args->{'one_time'}) {	if (!$args->{'one_time'}) {
&appenv(%envhash);	&appenv(\%envhash);
}	}
return %returnhash;	return %returnhash;
}	}
Line 3028 sub set_userprivs {	Line 3601 sub set_userprivs {
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {	foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);	my ($trole,$area,$sec,$extendedarea);
if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {	if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
$trole = $1;	$trole = $1;
$area = $2;	$area = $2;
$sec = $3;	$sec = $3;
Line 3048 sub set_userprivs {	Line 3621 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 3412 sub tmpget {	Line 3985 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 3509 sub get_portfolio_access {	Line 4083 sub get_portfolio_access {
}	}
if (@users > 0) {	if (@users > 0) {
foreach my $userkey (@users) {	foreach my $userkey (@users) {
if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {	if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
return 'ok';	foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
}	if (ref($item) eq 'HASH') {
	if (($item->{'uname'} eq $env{'user.name'}) &&
	($item->{'udom'} eq $env{'user.domain'})) {
	return 'ok';
	}
	}
	}
	}
}	}
}	}
my %roleshash;	my %roleshash;
Line 3671 sub customaccess {	Line 4252 sub customaccess {
$ucrs = &LONCAPA::clean_username($ucrs);	$ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;	my $access=0;
foreach my $right (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {	foreach my $right (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {
my ($effect,$realm,$role)=split(/\:/,$right);	my ($effect,$realm,$role,$type)=split(/\:/,$right);
if ($role) {	if ($type eq 'user') {
if ($role ne $urole) { next; }	foreach my $scope (split(/\s\,\s/,$realm)) {
}	my ($tdom,$tuname)=split(m{/},$scope);
foreach my $scope (split(/\s\,\s/,$realm)) {	if ($tdom) {
my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);	if ($tdom ne $env{'user.domain'}) { next; }
if ($tdom) {	}
if ($tdom ne $udom) { next; }	if ($tuname) {
}	if ($tuname ne $env{'user.name'}) { next; }
if ($tcrs) {	}
if ($tcrs ne $ucrs) { next; }	$access=($effect eq 'allow');
}	last;
if ($tsec) {	}
if ($tsec ne $usec) { next; }	} else {
}	if ($role) {
$access=($effect eq 'allow');	if ($role ne $urole) { next; }
last;	}
}	foreach my $scope (split(/\s\,\s/,$realm)) {
if ($realm eq '' && $role eq '') {	my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
$access=($effect eq 'allow');	if ($tdom) {
	if ($tdom ne $udom) { next; }
	}
	if ($tcrs) {
	if ($tcrs ne $ucrs) { next; }
	}
	if ($tsec) {
	if ($tsec ne $usec) { next; }
	}
	$access=($effect eq 'allow');
	last;
	}
	if ($realm eq '' && $role eq '') {
	$access=($effect eq 'allow');
	}
}	}
}	}
return $access;	return $access;
Line 4219 sub update_portfolio_table {	Line 4814 sub update_portfolio_table {
return $reply;	return $reply;
}	}

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

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

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

sub fetch_enrollment_query {	sub fetch_enrollment_query {
Line 4253 sub fetch_enrollment_query {	Line 4865 sub fetch_enrollment_query {
if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} else {	} else {
my @responses = split/:/,$reply;	my @responses = split(/:/,$reply);
if ($homeserver eq $perlvar{'lonHostID'}) {	if ($homeserver eq $perlvar{'lonHostID'}) {
foreach my $line (@responses) {	foreach my $line (@responses) {
my ($key,$value) = split(/=/,$line,2);	my ($key,$value) = split(/=/,$line,2);
Line 4296 sub get_query_reply {	Line 4908 sub get_query_reply {
sleep 2;	sleep 2;
if (-e $replyfile.'.end') {	if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {	if (open(my $fh,$replyfile)) {
$reply.=<$fh>;	$reply = join('',<$fh>);
close($fh);	close($fh);
} else { return 'error: reply_file_error'; }	} else { return 'error: reply_file_error'; }
return &unescape($reply);	return &unescape($reply);
}	}
Line 4328 sub courselog_query {	Line 4940 sub courselog_query {
}	}

sub userlog_query {	sub userlog_query {
	#
	# possible filters:
	# action: log check role
	# start: timestamp
	# end: timestamp
	#
my ($uname,$udom,%filters)=@_;	my ($uname,$udom,%filters)=@_;
return &log_query($uname,$udom,'userlog',%filters);	return &log_query($uname,$udom,'userlog',%filters);
}	}
Line 4336 sub userlog_query {	Line 4954 sub userlog_query {

sub auto_run {	sub auto_run {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $response = 0;
my $response = &reply('autorun:'.$cdom,$homeserver);	my $settings;
	my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
	if (ref($domconfig{'autoenroll'}) eq 'HASH') {
	$settings = $domconfig{'autoenroll'};
	if ($settings->{'run'} eq '1') {
	$response = 1;
	}
	} else {
	my $homeserver;
	if (&is_course($cdom,$cnum)) {
	$homeserver = &homeserver($cnum,$cdom);
	} else {
	$homeserver = &domain($cdom,'primary');
	}
	if ($homeserver ne 'no_host') {
	$response = &reply('autorun:'.$cdom,$homeserver);
	}
	}
return $response;	return $response;
}	}

Line 4347 sub auto_get_sections {	Line 4982 sub auto_get_sections {
my @secs = ();	my @secs = ();
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
unless ($response eq 'refused') {	unless ($response eq 'refused') {
@secs = split/:/,$response;	@secs = split(/:/,$response);
}	}
return @secs;	return @secs;
}	}
Line 4367 sub auto_validate_courseID {	Line 5002 sub auto_validate_courseID {
}	}

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam) = @_;	my ($cnum,$cdom,$authparam,$udom) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my ($homeserver,$response);
my $create_passwd = 0;	my $create_passwd = 0;
my $authchk = '';	my $authchk = '';
my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));	if ($udom =~ /^$match_domain$/) {
if ($response eq 'refused') {	$homeserver = &domain($udom,'primary');
$authchk = 'refused';	}
	if ($homeserver eq '') {
	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
	$homeserver = &homeserver($cnum,$cdom);
	}
	}
	if ($homeserver eq '') {
	$authchk = 'nodomain';
} else {	} else {
($authparam,$create_passwd,$authchk) = split/:/,$response;	$response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
	if ($response eq 'refused') {
	$authchk = 'refused';
	} else {
	($authparam,$create_passwd,$authchk) = split(/:/,$response);
	}
}	}
return ($authparam,$create_passwd,$authchk);	return ($authparam,$create_passwd,$authchk);
}	}
Line 4482 sub auto_instcode_format {	Line 5129 sub auto_instcode_format {
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);	$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {	if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =	my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
split/:/,$response;	split(/:/,$response);
%{$codes} = (%{$codes},&str2hash($codes_str));	%{$codes} = (%{$codes},&str2hash($codes_str));
push(@{$codetitles},&str2array($codetitles_str));	push(@{$codetitles},&str2array($codetitles_str));
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));	%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
Line 4528 sub auto_instcode_defaults {	Line 5175 sub auto_instcode_defaults {
}	}

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

Line 4699 sub plaintext {	Line 5352 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)=@_;
my $mrole;	my $mrole;
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
my $cwosec=$url;	my $cwosec=$url;
Line 4724 sub assignrole {	Line 5377 sub assignrole {
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless ((&allowed('c'.$role,$cwosec)) \|\| &allowed('c'.$role,$udom)) {	if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
&logthis('Refused assignrole: '.	my $refused;
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	if (($env{'request.course.sec'} ne '') && ($role eq 'st')) {
$env{'user.name'}.' at '.$env{'user.domain'});	if (!(&allowed('c'.$role,$url))) {
return 'refused';	$refused = 1;
	}
	} else {
	$refused = 1;
	}
	if ($refused) {
	if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
	$refused = '';
	} else {
	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
	' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
	}
}	}
$mrole=$role;	$mrole=$role;
}	}
Line 4862 sub modifyuser {	Line 5529 sub modifyuser {
}	}
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
my @tmp=&get('environment',	my @tmp=&get('environment',
['firstname','middlename','lastname','generation'],	['firstname','middlename','lastname','generation','id',
	'permanentemail'],
$udom,$uname);	$udom,$uname);
my %names;	my %names;
if ($tmp[0] =~ m/^error:.*/) {	if ($tmp[0] =~ m/^error:.*/) {
Line 4884 sub modifyuser {	Line 5552 sub modifyuser {
$names{'critnotification'} = $email;	$names{'critnotification'} = $email;
$names{'permanentemail'} = $email; }	$names{'permanentemail'} = $email; }
}	}
	if ($uid) { $names{'id'} = $uid; }
my $reply = &put('environment', \%names, $udom,$uname);	my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }	if ($reply ne 'ok') { return 'error: '.$reply; }
	my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);	&devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
Line 4918 sub modifystudent {	Line 5588 sub modifystudent {
}	}

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) = @_;
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 4976 sub modify_student_enrollment {	Line 5646 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);
}	}

sub format_name {	sub format_name {
Line 5057 sub createcourse {	Line 5727 sub createcourse {
}	}
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).	my $newcourse = {
':'.&escape($inst_code).':'.&escape($course_owner).':'.	$udom.'_'.$uname => {
&escape($crstype),$uhome);	description => $description,
&flushcourselogs();	inst_code => $inst_code,
	owner => $course_owner,
	type => $crstype,
	},
	};
	&courseidput($udom,$newcourse,$uhome,'notime');
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
unless ($nonstandard) {	unless ($nonstandard) {
Line 5180 sub save_selected_files {	Line 5855 sub save_selected_files {
my ($user, $path, @files) = @_;	my ($user, $path, @files) = @_;
my $filename = $user."savedfiles";	my $filename = $user."savedfiles";
my @other_files = &files_not_in_path($user, $path);	my @other_files = &files_not_in_path($user, $path);
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);	open (OUT, '>'.$tmpdir.$filename);
foreach my $file (@files) {	foreach my $file (@files) {
print (OUT $env{'form.currentpath'}.$file."\n");	print (OUT $env{'form.currentpath'}.$file."\n");
}	}
Line 5705 sub directcondval {	Line 6380 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 5772 sub devalidatecourseresdata {	Line 6447 sub devalidatecourseresdata {


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

sub get_courseresdata {	sub get_courseresdata {
my ($coursenum,$coursedomain)=@_;	my ($coursenum,$coursedomain)=@_;
Line 5830 sub get_userresdata {	Line 6512 sub get_userresdata {
}	}
return $tmp;	return $tmp;
}	}
	#----------------------------------------------- resdata - return resource data
	# Purpose:
	# Return resource data for either users or for a course.
	# Parameters:
	# $name - Course/user name.
	# $domain - Name of the domain the user/course is registered on.
	# $type - Type of thing $name is (must be 'course' or 'user'
	# @which - Array of names of resources desired.
	# Returns:
	# The value of the first reasource in @which that is found in the
	# resource hash.
	# Exceptional Conditions:
	# If the $type passed in is not valid (not the string 'course' or
	# 'user', an undefined reference is returned.
	# If none of the resources are found, an undef is returned
sub resdata {	sub resdata {
my ($name,$domain,$type,@which)=@_;	my ($name,$domain,$type,@which)=@_;
my $result;	my $result;
Line 5841 sub resdata {	Line 6537 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 5870 sub EXT_cache_status {	Line 6566 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 6008 sub EXT {	Line 6704 sub EXT {
my ($map) = &decode_symb($symbparm);	my ($map) = &decode_symb($symbparm);
return &symbread($map);	return &symbread($map);
}	}
	if ($space eq 'filename') {
	if ($symbparm) {
	return &clutter((&decode_symb($symbparm))[2]);
	}
	return &hreflocation('',$env{'request.filename'});
	}

my ($section, $group, @groups);	my ($section, $group, @groups);
my ($courselevelm,$courselevel);	my ($courselevelm,$courselevel);
Line 6048 sub EXT {	Line 6750 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 6076 sub EXT {	Line 6781 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 6089 sub EXT {	Line 6794 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 6108 sub EXT {	Line 6814 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 6143 sub EXT {	Line 6848 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 6177 sub packages_tab_default {	Line 6894 sub packages_tab_default {
$do_default=1;	$do_default=1;
} elsif ($pack_type eq 'extension') {	} elsif ($pack_type eq 'extension') {
push(@extension,[$package,$pack_type,$pack_part]);	push(@extension,[$package,$pack_type,$pack_part]);
} else {	} elsif ($pack_part eq $part \|\| $pack_type eq 'part') {
	# only look at packages defaults for packages that this id is
push(@specifics,[$package,$pack_type,$pack_part]);	push(@specifics,[$package,$pack_type,$pack_part]);
}	}
}	}
Line 6243 sub metadata {	Line 6961 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 6265 sub metadata {	Line 6986 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 6275 sub metadata {	Line 6997 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 6380 sub metadata {	Line 7108 sub metadata {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$metaentry{':'.$unikey}=$default;	$metaentry{':'.$unikey}=$default;
} else {	} elsif ( $internaltext =~ /\S/ ) {
# either something interesting inside the tag or default	# something interesting inside the tag
# uninteresting
$metaentry{':'.$unikey}=$internaltext;	$metaentry{':'.$unikey}=$internaltext;
	} else {
	# no interesting values, don't set a default
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 6393 sub metadata {	Line 7122 sub metadata {
}	}
}	}
my ($extension) = ($uri =~ /\.(\w+)$/);	my ($extension) = ($uri =~ /\.(\w+)$/);
	$extension = lc($extension);
	if ($extension eq 'htm') { $extension='html'; }

foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension	#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }	if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,	&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);	\%metathesekeys);
}	}
if (!exists($metaentry{':packages'})) {
	if (!exists($metaentry{':packages'})
	\|\| $packagetab{"import_defaults&extension_$extension"}) {
foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages well let's get default then	#no specific packages well let's get default then
if ($key!~/^default&/) { next; }	if ($key!~/^default&/) { next; }
Line 6436 sub metadata {	Line 7170 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 6518 sub gettitle {	Line 7252 sub gettitle {
}	}
my ($map,$resid,$url)=&decode_symb($symb);	my ($map,$resid,$url)=&decode_symb($symb);
my $title='';	my $title='';
my %bighash;	if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',	$title = $env{'course.'.$env{'request.course.id'}.'.description'};
&GDBM_READER(),0640)) {	} else {
my $mapid=$bighash{'map_pc_'.&clutter($map)};	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
$title=$bighash{'title_'.$mapid.'.'.$resid};	&GDBM_READER(),0640)) {
untie %bighash;	my $mapid=$bighash{'map_pc_'.&clutter($map)};
	$title=$bighash{'title_'.$mapid.'.'.$resid};
	untie(%bighash);
	}
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
Line 6731 sub symbread {	Line 7468 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 6783 sub symbread {	Line 7520 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 6895 sub getCODE {	Line 7632 sub getCODE {

sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;

my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();	my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {	if (!defined($symb)) {
unless ($symb=$wsymb) { return time; }	unless ($symb=$wsymb) { return time; }
}	}
if (!$courseid) { $courseid=$wcourseid; }	if (!$courseid) { $courseid=$wcourseid; }
Line 7298 sub tokenwrapper {	Line 8034 sub tokenwrapper {
my (undef,$udom,$uname,$file)=split('/',$uri,4);	my (undef,$udom,$uname,$file)=split('/',$uri,4);
if ($udom && $uname && $file) {	if ($udom && $uname && $file) {
$file=~s\|(\?\.)$\|\|;	$file=~s\|(\?\.)$\|\|;
&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});	&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.	return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
Line 7349 sub filelocation {	Line 8085 sub filelocation {
$file=~s-^/adm/wrapper/-/-;	$file=~s-^/adm/wrapper/-/-;
$file=~s-^/adm/coursedocs/showdoc/-/-;	$file=~s-^/adm/coursedocs/showdoc/-/-;
}	}

if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
Line 7369 sub filelocation {	Line 8106 sub filelocation {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;	$udom.'/'.$uname.'/'.$filename;
}	}
	} elsif ($file =~ m-^/adm/-) {
	$location = $perlvar{'lonDocRoot'}.'/'.$file;
} else {	} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;	$file=~s:^/res/:/:;
Line 7379 sub filelocation {	Line 8118 sub filelocation {
}	}
}	}
$location=~s://+:/:g; # remove duplicate /	$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m{/\.\./}) {
	if ($location =~ m{/[^/]+/\.\./}) {
	$location=~ s{/[^/]+/\.\./}{/}g;
	} else {
	$location=~ s{/\.\./}{/}g;
	}
	} #remove dir/..
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;	return $location;
}	}
Line 7400 sub hreflocation {	Line 8145 sub hreflocation {
$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;	-/uploaded/$1/$2/-x;
}	}
	if ($file=~ m{^/userfiles/}) {
	$file =~ s{^/userfiles/}{/uploaded/};
	}
return $file;	return $file;
}	}

sub current_machine_domains {	sub current_machine_domains {
my $hostname=&hostname($perlvar{'lonHostID'});	return &machine_domains(&hostname($perlvar{'lonHostID'}));
	}

	sub machine_domains {
	my ($hostname) = @_;
my @domains;	my @domains;
my %hostname = &all_hostnames();	my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {	while( my($id, $name) = each(%hostname)) {
Line 7417 sub current_machine_domains {	Line 8169 sub current_machine_domains {
}	}

sub current_machine_ids {	sub current_machine_ids {
my $hostname=&hostname($perlvar{'lonHostID'});	return &machine_ids(&hostname($perlvar{'lonHostID'}));
	}

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

sub additional_machine_domains {	sub additional_machine_domains {
Line 7470 sub declutter {	Line 8224 sub declutter {

sub clutter {	sub clutter {
my $thisfn='/'.&declutter(shift);	my $thisfn='/'.&declutter(shift);
unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {	if ($thisfn !~ m{^/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)/}
	\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
if ($thisfn !~m\|/adm\|) {	if ($thisfn !~m\|/adm\|) {
Line 7539 sub correct_line_ends {	Line 8294 sub correct_line_ends {
sub goodbye {	sub goodbye {
&logthis("Starting Shut down");	&logthis("Starting Shut down");
#not converted to using infrastruture and probably shouldn't be	#not converted to using infrastruture and probably shouldn't be
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));	&logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
#converted	#converted
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));	# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
&logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));	&logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));	# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));	# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
#1.1 only	#1.1 only
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));	# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));	# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));	# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));	# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));	&logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
&logthis(sprintf("%-20s is %s",'kicks',$kicks));	&logthis(sprintf("%-20s is %s",'kicks',$kicks));
&logthis(sprintf("%-20s is %s",'hits',$hits));	&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
}	}

BEGIN {	sub get_dns {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	my ($url,$func,$ignore_cache) = @_;
unless ($readit) {	if (!$ignore_cache) {
{	my ($content,$cached)=
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');	&Apache::lonnet::is_cached_new('dns',$url);
%perlvar = (%perlvar,%{$configvars});	if ($cached) {
}	&$func($content);
	return;
	}
	}

	my %alldns;
	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
	foreach my $dns (<$config>) {
	next if ($dns !~ /^\^(\S*)/x);
	$alldns{$1} = 1;
	}
	while (%alldns) {
	my ($dns) = keys(%alldns);
	delete($alldns{$dns});
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',"http://$dns$url");
	my $response=$ua->request($request);
	next if ($response->is_error());
	my @content = split("\n",$response->content);
	&Apache::lonnet::do_cache_new('dns',$url,\@content,302460*60);
	&$func(\@content);
	return;
	}
	close($config);
	my $which = (split('/',$url))[3];
	&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
	open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
	my @content = <$config>;
	&$func(\@content);
	return;
	}
# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
%domaindescription = ();	my $loaded;
%domain_auth_def = ();	my %domain;
%domain_auth_arg_def = ();
my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
while (my $line = <$fh>) {
next if ($line =~ /^(\#\|\s*$)/);
# next if /^\#/;
chomp $line;
my ($domain, $domain_description, $def_auth, $def_auth_arg,
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;
$domain_lang_def{$domain}=$def_lang;
$domain_city{$domain}=$city;
$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;
$domain_primary{$domain}=$primary;

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	sub parse_domain_tab {
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	my ($lines) = @_;
	foreach my $line (@$lines) {
	next if ($line =~ /^(\#\|\s*$ )/x);

	chomp($line);
	my ($name,@elements) = split(/:/,$line,9);
	my %this_domain;
	foreach my $field ('description', 'auth_def', 'auth_arg_def',
	'lang_def', 'city', 'longi', 'lati',
	'primary') {
	$this_domain{$field} = shift(@elements);
	}
	$domain{$name} = \%this_domain;
}	}
}	}
close ($fh);
	sub reset_domain_info {
	undef($loaded);
	undef(%domain);
	}

	sub load_domain_tab {
	my ($ignore_cache) = @_;
	&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
	my $fh;
	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
	my @lines = <$fh>;
	&parse_domain_tab(\@lines);
	}
	close($fh);
	$loaded = 1;
	}

	sub domain {
	&load_domain_tab() if (!$loaded);

	my ($name,$what) = @_;
	return if ( !exists($domain{$name}) );

	if (!$what) {
	return $domain{$name}{'description'};
	}
	return $domain{$name}{$what};
	}
}	}


Line 7600 BEGIN {	Line 8407 BEGIN {
my %hostname;	my %hostname;
my %hostdom;	my %hostdom;
my %libserv;	my %libserv;
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	my $loaded;
	my %name_to_host;

while (my $configline=<$config>) {	sub parse_hosts_tab {
next if ($configline =~ /^(\#\|\s*$)/);	my ($file) = @_;
chomp($configline);	foreach my $configline (@$file) {
my ($id,$domain,$role,$name)=split(/:/,$configline);	next if ($configline =~ /^(\#\|\s*$ )/x);
$name=~s/\s//g;	next if ($configline =~ /^\^/);
if ($id && $domain && $role && $name) {	chomp($configline);
$hostname{$id}=$name;	my ($id,$domain,$role,$name)=split(/:/,$configline);
$hostdom{$id}=$domain;	$name=~s/\s//g;
if ($role eq 'library') { $libserv{$id}=$name; }	if ($id && $domain && $role && $name) {
}	$hostname{$id}=$name;
	push(@{$name_to_host{$name}}, $id);
	$hostdom{$id}=$domain;
	if ($role eq 'library') { $libserv{$id}=$name; }
	}
	}
	}

	sub reset_hosts_info {
	&purge_remembered();
	&reset_domain_info();
	&reset_hosts_ip_info();
	undef(%name_to_host);
	undef(%hostname);
	undef(%hostdom);
	undef(%libserv);
	undef($loaded);
	}

	sub load_hosts_tab {
	my ($ignore_cache) = @_;
	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
	my @config = <$config>;
	&parse_hosts_tab(\@config);
	close($config);
	$loaded=1;
}	}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();

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

my ($lonid) = @_;	my ($lonid) = @_;
return $hostname{$lonid};	return $hostname{$lonid};
}	}

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

return %hostname;	return %hostname;
}	}

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

	return %name_to_host;
	}

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

return exists($libserv{$_[0]});	return exists($libserv{$_[0]});
}	}

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

return %libserv;	return %libserv;
}	}

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

my ($domain,$type) = @_;	my ($domain,$type) = @_;
my %possible_hosts = ($type eq 'library') ? %libserv	my %possible_hosts = ($type eq 'library') ? %libserv
: %hostname;	: %hostname;
Line 7656 BEGIN {	Line 8503 BEGIN {
}	}

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

my ($lonid) = @_;	my ($lonid) = @_;
return $hostdom{$lonid};	return $hostdom{$lonid};
}	}

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

my %seen;	my %seen;
my @uniq = grep(!$seen{$_}++, values(%hostdom));	my @uniq = grep(!$seen{$_}++, values(%hostdom));
return @uniq;	return @uniq;
}	}
}	}

sub get_hosts_from_ip {	{
my ($ip) = @_;	my %iphost;
my %iphosts = &get_iphost();	my %name_to_ip;
if (ref($iphosts{$ip})) {	my %lonid_to_ip;
return @{$iphosts{$ip}};
	sub get_hosts_from_ip {
	my ($ip) = @_;
	my %iphosts = &get_iphost();
	if (ref($iphosts{$ip})) {
	return @{$iphosts{$ip}};
	}
	return;
	}

	sub reset_hosts_ip_info {
	undef(%iphost);
	undef(%name_to_ip);
	undef(%lonid_to_ip);
}	}
return;
}

sub get_iphost {	sub get_host_ip {
if (%iphost) { return %iphost; }	my ($lonid) = @_;
my %name_to_ip;	if (exists($lonid_to_ip{$lonid})) {
my %hostname = &all_hostnames();	return $lonid_to_ip{$lonid};
foreach my $id (keys(%hostname)) {	}
my $name=$hostname{$id};	my $name=&hostname($lonid);
my $ip;	my $ip = gethostbyname($name);
if (!exists($name_to_ip{$name})) {	return if (!$ip \|\| length($ip) ne 4);
$ip = gethostbyname($name);	$ip=inet_ntoa($ip);
if (!$ip \|\| length($ip) ne 4) {	$name_to_ip{$name} = $ip;
&logthis("Skipping host $id name $name no IP found");	$lonid_to_ip{$lonid} = $ip;
next;	return $ip;
	}

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

	if (!$ignore_cache) {
	if (%iphost) {
	return %iphost;
}	}
$ip=inet_ntoa($ip);	my ($ip_info,$cached)=
$name_to_ip{$name} = $ip;	&Apache::lonnet::is_cached_new('iphost','iphost');
} else {	if ($cached) {
$ip = $name_to_ip{$name};	%iphost = %{$ip_info->[0]};
	%name_to_ip = %{$ip_info->[1]};
	%lonid_to_ip = %{$ip_info->[2]};
	return %iphost;
	}
	}

	# get yesterday's info for fallback
	my %old_name_to_ip;
	my ($ip_info,$cached)=
	&Apache::lonnet::is_cached_new('iphost','iphost');
	if ($cached) {
	%old_name_to_ip = %{$ip_info->[1]};
	}

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

	return %iphost;
}	}
return %iphost;
}	}

	BEGIN {

	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
	unless ($readit) {
	{
	my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
	%perlvar = (%perlvar,%{$configvars});
	}


# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
{	{
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");	open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
Line 7958 that was requested	Line 8879 that was requested

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

=item *	=item *
X<delenv()>	X<delenv()>
Line 8030 X<userenvironment()>	Line 8953 X<userenvironment()>
B<userenvironment($udom,$uname,@what)>: gets the values of the keys	B<userenvironment($udom,$uname,@what)>: gets the values of the keys
passed in @what from the requested user's environment, returns a hash	passed in @what from the requested user's environment, returns a hash

	=item *
	X<userlog_query()>
	B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
	activity.log file. %filters defines filters applied when parsing the
	log file. These can be start or end timestamps, or the type of action
	- log to look for Login or Logout events, check for Checkin or
	Checkout, role for role selection. The response is in the form
	timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are
	escaped strings of the action recorded in the activity.log file.

=back	=back

=head2 User Roles	=head2 User Roles
Line 8059 explanation of a user role term	Line 8992 explanation of a user role term

=item *	=item *

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

=back	=back

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

	=item *

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


=back	=back

=head2 Course Modification	=head2 Course Modification
Line 8493 critical subroutine	Line 9437 critical subroutine

=item *	=item *

get_dom($namespace,$storearr,$udomain) : returns hash with keys from array	get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
reference filled in from namespace found in domain level on primary domain server ($udomain is optional)	array reference filled in from namespace found in domain level on either
	specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).

=item *	=item *

put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)	put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at
	domain level either on specified domain server ($uhome) or primary domain
	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

Line 8891 symblist($mapname,%newhash) : update sym	Line 9850 symblist($mapname,%newhash) : update sym
=back	=back

=cut	=cut

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

Removed from v.1.845
changed lines
	Added in v.1.953