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.833 and 1.899

version 1.833, 2007/02/18 01:51:20	version 1.899, 2007/07/26 02:09:24
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 %hostname %badServerCache %iphost %spareid %hostdom	$_64bit %env);
%libserv %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)=@_;
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};	my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
#	#
# With loncnew process trimming, there's a timing hole between lonc server	# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX	# process exit and the master server picking up the listen on the AF_UNIX
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 189 sub subreply {	Line 202 sub subreply {

sub reply {	sub reply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless (defined($hostname{$server})) { return 'no_such_host'; }	unless (defined(&hostname($server))) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {	if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {
&logthis("<font color=\"blue\">WARNING:".	&logthis("<font color=\"blue\">WARNING:".
Line 201 sub reply {	Line 214 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {	sub reconlonc {
my $peerfile=shift;	my ($lonid) = @_;
&logthis("Trying to reconnect for $peerfile");	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");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {	if (open(my $fh,"<$loncfile")) {
my $loncpid=<$fh>;	my $loncpid=<$fh>;
Line 211 sub reconlonc {	Line 241 sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");	&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;	kill USR1 => $loncpid;
sleep 1;	sleep 1;
if (-e "$peerfile") { return; }	} else {
&logthis("$peerfile still not there, give it another try");
sleep 5;
if (-e "$peerfile") { return; }
&logthis(
"<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
} else {
&logthis(	&logthis(
"<font color=\"blue\">WARNING:".	"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");	" lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}	}
}	}

Line 231 sub reconlonc {	Line 255 sub reconlonc {

sub critical {	sub critical {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless ($hostname{$server}) {	unless (&hostname($server)) {
&logthis("<font color=\"blue\">WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");	" Critical message to unknown server ($server)</font>");
return 'no_such_host';	return 'no_such_host';
Line 524 sub spareserver {	Line 548 sub spareserver {
}	}

if (!$want_server_name) {	if (!$want_server_name) {
$spare_server="http://$hostname{$spare_server}";	$spare_server="http://".&hostname($spare_server);
}	}
return $spare_server;	return $spare_server;
}	}
Line 615 sub authenticate {	Line 639 sub authenticate {
my ($uname,$upass,$udom)=@_;	my ($uname,$upass,$udom)=@_;
$upass=&escape($upass);	$upass=&escape($upass);
$uname= &LONCAPA::clean_username($uname);	$uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom,1);
if (!$uhome) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown in authenticate");	# Maybe the machine was offline and only re-appeared again recently?
	&reconlonc();
	# One more
	my $uhome=&homeserver($uname,$udom,1);
	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
	&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",$uhome);
Line 641 sub homeserver {	Line 671 sub homeserver {
my $index="$uname:$udom";	my $index="$uname:$udom";

if (exists($homecache{$index})) { return $homecache{$index}; }	if (exists($homecache{$index})) { return $homecache{$index}; }
my $tryserver;
foreach $tryserver (keys %libserv) {	my %servers = &get_servers($udom,'library');
	foreach my $tryserver (keys(%servers)) {
next if ($ignoreBadCache ne 'true' &&	next if ($ignoreBadCache ne 'true' &&
exists($badServerCache{$tryserver}));	exists($badServerCache{$tryserver}));
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);	my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {	if ($answer eq 'found') {
return $homecache{$index}=$tryserver;	delete($badServerCache{$tryserver});
} elsif ($answer eq 'no_host') {	return $homecache{$index}=$tryserver;
$badServerCache{$tryserver}=1;	} elsif ($answer eq 'no_host') {
}	$badServerCache{$tryserver}=1;
}	}
}	}
return 'no_host';	return 'no_host';
}	}
Line 663 sub idget {	Line 694 sub idget {
my ($udom,@ids)=@_;	my ($udom,@ids)=@_;
my %returnhash=();	my %returnhash=();

my $tryserver;	my %servers = &get_servers($udom,'library');
foreach $tryserver (keys %libserv) {	foreach my $tryserver (keys(%servers)) {
if ($hostdom{$tryserver} eq $udom) {	my $idlist=join('&',@ids);
my $idlist=join('&',@ids);	$idlist=~tr/A-Z/a-z/;
$idlist=~tr/A-Z/a-z/;	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
my $reply=&reply("idget:$udom:".$idlist,$tryserver);	my @answer=();
my @answer=();	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {	@answer=split(/\&/,$reply);
@answer=split(/\&/,$reply);	} ;
} ;	my $i;
my $i;	for ($i=0;$i<=$#ids;$i++) {
for ($i=0;$i<=$#ids;$i++) {	if ($answer[$i]) {
if ($answer[$i]) {	$returnhash{$ids[$i]}=$answer[$i];
$returnhash{$ids[$i]}=$answer[$i];	}
}	}
}	}
}
}
return %returnhash;	return %returnhash;
}	}

Line 722 sub idput {	Line 751 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 744 sub get_dom {	Line 788 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 762 sub put_dom {	Line 818 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 {
	my ($udom) = @_;
	my (%returnhash,@order);
	if (defined(&domain($udom,'primary'))) {
	my $uhome=&domain($udom,'primary');
	my $rep=&reply("inst_usertypes:$udom",$uhome);
	my ($hashitems,$orderitems) = split(/:/,$rep);
	my @pairs=split(/\&/,$hashitems);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
	my @esc_order = split(/\&/,$orderitems);
	foreach my $item (@esc_order) {
	push(@order,&unescape($item));
	}
	} else {
	&logthis("get_dom failed - no primary domain server for $udom");
}	}
	return (\%returnhash,\@order);
	}

	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');
	if ($homeserver ne '') {
	my $response=&reply("instdirsrch:$udom".':'.
	&escape($srch->{'srchby'}).':'.
	&escape($srch->{'srchterm'}).':'.
	$srch->{'srchtype'},$homeserver);
	unless ($response eq 'refused') {
	my @matches = split/&/,$response;
	foreach my $match (@matches) {
	my ($key,$value) = split(/=/,$match);
	my %userhash = &str2hash(&unescape($value));
	$results{&unescape($key).':'.$udom} = \%userhash;
	}
	}
	}
	return %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($dom).':'.
	&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);
	return 'error: '.$queryid;
	}
	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 = split/&/,$reply;
	foreach my $match (@matches) {
	my @items = split(/:/,$match);
	my ($uname,$udom,%userhash);
	foreach my $entry (@items) {
	my ($key,$value) = split(/=/,$entry);
	$key = &unescape($key);
	$value = &unescape($value);
	$userhash{$key} = $value;
	if ($key eq 'username') {
	$uname = $value;
	} elsif ($key eq 'domain') {
	$udom = $value;
	}
	}
	$results{$uname.':'.$udom} = \%userhash;
	}
	}
	}
	}
	return %results;
}	}

# --------------------------------------------------- Assign a key to a student	# --------------------------------------------------- Assign a key to a student
Line 990 my %remembered;	Line 1153 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 1001 sub devalidate_cache_new {	Line 1173 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 1024 sub is_cached_new {	Line 1196 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 1033 sub do_cache_new {	Line 1205 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);	if (!($memcache->set($id,$setvalue,$time))) {
	&logthis("caching of id -> $id failed");
	}
# 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;
Line 1295 sub ssi {	Line 1469 sub ssi {
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 1474 sub clean_filename {	Line 1648 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 1528 sub userfileupload {	Line 1709 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 1538 sub userfileupload {	Line 1719 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 1548 sub userfileupload {	Line 1730 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 1593 sub finishuserfileupload {	Line 1777 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 1605 sub finishuserfileupload {	Line 1806 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 1629 sub extract_embedded_items {	Line 1830 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 1819 sub flushcourselogs {	Line 2023 sub flushcourselogs {
# 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 $crsid (keys(%courseidbuffer)) {	foreach my $crs_home (keys(%courseidbuffer)) {
&courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);	&courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},
	$crs_home);
}	}
#	#
# File accesses	# File accesses
Line 1887 sub flushcourselogs {	Line 2092 sub flushcourselogs {
delete $domainrolehash{$entry};	delete $domainrolehash{$entry};
}	}
foreach my $dom (keys(%domrolebuffer)) {	foreach my $dom (keys(%domrolebuffer)) {
foreach my $tryserver (keys %libserv) {	my %servers = &get_servers($dom,'library');
if ($hostdom{$tryserver} eq $dom) {	foreach my $tryserver (keys(%servers)) {
unless (&reply('domroleput:'.$dom.':'.	unless (&reply('domroleput:'.$dom.':'.
$domrolebuffer{$dom},$tryserver) eq 'ok') {	$domrolebuffer{$dom},$tryserver) eq 'ok') {
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);	&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
}	}
}
}	}
}	}
$dumpcount++;	$dumpcount++;
Line 1982 sub userrolelog {	Line 2186 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 1991 sub userrolelog {	Line 2203 sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
= $tend.':'.$tstart;	= $tend.':'.$tstart;
}	}
	&flushcourselogs();
}	}

sub get_course_adv_roles {	sub get_course_adv_roles {
Line 2027 sub get_course_adv_roles {	Line 2240 sub get_course_adv_roles {
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom,$types,$roles,$roledoms)=@_;	my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
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;
	if ($context eq 'userroles') {
	%dumphash = &dump('roles',$udom,$uname);
	} else {
	%dumphash=
&dump('nohist_userroles',$udom,$uname);	&dump('nohist_userroles',$udom,$uname);
	}
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)) {
Line 2053 sub get_my_roles {	Line 2276 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 2063 sub get_my_roles {	Line 2292 sub get_my_roles {
if (!grep(/^\Q$role\E$/,@{$roles})) {	if (!grep(/^\Q$role\E$/,@{$roles})) {
next;	next;
}	}
}	}
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}	}
return %returnhash;	return %returnhash;
Line 2075 sub get_my_roles {	Line 2304 sub get_my_roles {

sub postannounce {	sub postannounce {
my ($server,$text)=@_;	my ($server,$text)=@_;
unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }	unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
unless ($text=~/\w/) { $text=''; }	unless ($text=~/\w/) { $text=''; }
return &reply('setannounce:'.&escape($text),$server);	return &reply('setannounce:'.&escape($text),$server);
}	}
Line 2111 sub courseiddump {	Line 2340 sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
my %returnhash=();	my %returnhash=();
unless ($domfilter) { $domfilter=''; }	unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {	my %libserv = &all_library();
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) \|\| (!defined($hostidflag)) ) {	foreach my $tryserver (keys(%libserv)) {
if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {	if ( ( $hostidflag == 1
	&& grep(/^\Q$tryserver\E$/,@{$hostidref}) )
	\|\| (!defined($hostidflag)) ) {

	if ($domfilter eq ''
	\|\| (&host_domain($tryserver) eq $domfilter)) {
foreach my $line (	foreach my $line (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.	split(/\&/,&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).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
$tryserver))) {	$tryserver))) {
Line 2143 sub dcmailput {	Line 2377 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 2169 sub get_domain_roles {	Line 2404 sub get_domain_roles {
}	}
my $rolelist = join(':',@{$roles});	my $rolelist = join(':',@{$roles});
my %personnel = ();	my %personnel = ();
foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $dom) {	my %servers = &get_servers($dom,'library');
%{$personnel{$tryserver}}=();	foreach my $tryserver (keys(%servers)) {
foreach my $line (	%{$personnel{$tryserver}}=();
split(/\&/,&reply('domrolesdump:'.$dom.':'.	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
&escape($startdate).':'.&escape($enddate).':'.	&escape($startdate).':'.
&escape($rolelist), $tryserver))) {	&escape($enddate).':'.
my ($key,$value) = split(/\=/,$line,2);	&escape($rolelist), $tryserver))) {
if (($key) && ($value)) {	my ($key,$value) = split(/\=/,$line,2);
$personnel{$tryserver}{&unescape($key)} = &unescape($value);	if (($key) && ($value)) {
}	$personnel{$tryserver}{&unescape($key)} = &unescape($value);
}	}
}	}
}	}
return %personnel;	return %personnel;
}	}
Line 2271 sub checkin {	Line 2506 sub checkin {
my $now=time;	my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);	my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;	$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;	my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;	$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=	my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));	split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 2940 sub custom_roleprivs {	Line 3175 sub custom_roleprivs {
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;	my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);	my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
my $homsvr=homeserver($rauthor,$rdomain);	my $homsvr=homeserver($rauthor,$rdomain);
if ($hostname{$homsvr} ne '') {	if (&hostname($homsvr) ne '') {
my ($rdummy,$roledef)=	my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);	&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
if (($rdummy ne 'con_lost') && ($roledef ne '')) {	if (($rdummy ne 'con_lost') && ($roledef ne '')) {
Line 3001 sub set_userprivs {	Line 3236 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 3482 sub get_portfolio_access {	Line 3717 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 3644 sub customaccess {	Line 3886 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 4148 sub definerole {	Line 4404 sub definerole {
sub metadata_query {	sub metadata_query {
my ($query,$custom,$customshow,$server_array)=@_;	my ($query,$custom,$customshow,$server_array)=@_;
my %rhash;	my %rhash;
	my %libserv = &all_library();
my @server_list = (defined($server_array) ? @$server_array	my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );	: keys(%libserv) );
for my $server (@server_list) {	for my $server (@server_list) {
Line 4171 sub log_query {	Line 4428 sub log_query {
my ($uname,$udom,$query,%filters)=@_;	my ($uname,$udom,$query,%filters)=@_;
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if ($uhome eq 'no_host') { return 'error: no_host'; }	if ($uhome eq 'no_host') { return 'error: no_host'; }
my $uhost=$hostname{$uhome};	my $uhost=&hostname($uhome);
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));	my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,	my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);	$uhome);
Line 4191 sub update_portfolio_table {	Line 4448 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 4203 sub fetch_enrollment_query {	Line 4477 sub fetch_enrollment_query {
} else {	} else {
$homeserver = &homeserver($cnum,$dom);	$homeserver = &homeserver($cnum,$dom);
}	}
my $host=$hostname{$homeserver};	my $host=&hostname($homeserver);
my $cmd = '';	my $cmd = '';
foreach my $affiliate (keys %{$affiliatesref}) {	foreach my $affiliate (keys %{$affiliatesref}) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
Line 4300 sub courselog_query {	Line 4574 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 4308 sub userlog_query {	Line 4588 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 = &homeserver($cnum,$cdom);
	$response = &reply('autorun:'.$cdom,$homeserver);
	}
return $response;	return $response;
}	}

Line 4339 sub auto_validate_courseID {	Line 4629 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 4394 sub auto_photochoice {	Line 4696 sub auto_photochoice {
sub auto_photoupdate {	sub auto_photoupdate {
my ($affiliatesref,$dom,$cnum,$photo) = @_;	my ($affiliatesref,$dom,$cnum,$photo) = @_;
my $homeserver = &homeserver($cnum,$dom);	my $homeserver = &homeserver($cnum,$dom);
my $host=$hostname{$homeserver};	my $host=&hostname($homeserver);
my $cmd = '';	my $cmd = '';
my $maxtries = 1;	my $maxtries = 1;
foreach my $affiliate (keys(%{$affiliatesref})) {	foreach my $affiliate (keys(%{$affiliatesref})) {
Line 4434 sub auto_instcode_format {	Line 4736 sub auto_instcode_format {
my $courses = '';	my $courses = '';
my @homeservers;	my @homeservers;
if ($caller eq 'global') {	if ($caller eq 'global') {
foreach my $tryserver (keys(%libserv)) {	my %servers = &get_servers($codedom,'library');
if ($hostdom{$tryserver} eq $codedom) {	foreach my $tryserver (keys(%servers)) {
if (!grep(/^\Q$tryserver\E$/,@homeservers)) {	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
push(@homeservers,$tryserver);	push(@homeservers,$tryserver);
}	}
}
}	}
} else {	} else {
push(@homeservers,&homeserver($caller,$codedom));	push(@homeservers,&homeserver($caller,$codedom));
Line 4473 sub auto_instcode_format {	Line 4774 sub auto_instcode_format {
sub auto_instcode_defaults {	sub auto_instcode_defaults {
my ($domain,$returnhash,$code_order) = @_;	my ($domain,$returnhash,$code_order) = @_;
my @homeservers;	my @homeservers;
foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $domain) {	my %servers = &get_servers($domain,'library');
if (!grep(/^\Q$tryserver\E$/,@homeservers)) {	foreach my $tryserver (keys(%servers)) {
push(@homeservers,$tryserver);	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
}	push(@homeservers,$tryserver);
}	}
}	}
my $ok_response = 0;
my $response;	my $response;
while (@homeservers > 0 && $ok_response == 0) {	foreach my $server (@homeservers) {
my $server = shift(@homeservers);
$response=&reply('autoinstcodedefaults:'.$domain,$server);	$response=&reply('autoinstcodedefaults:'.$domain,$server);
if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {	next if ($response =~ /(con_lost\|error\|no_such_host\|refused)/);
foreach my $pair (split(/\&/,$response)) {
my ($name,$value)=split(/\=/,$pair);	foreach my $pair (split(/\&/,$response)) {
if ($name eq 'code_order') {	my ($name,$value)=split(/\=/,$pair);
@{$code_order} = split(/\&/,&unescape($value));	if ($name eq 'code_order') {
} else {	@{$code_order} = split(/\&/,&unescape($value));
$returnhash->{&unescape($name)}=&unescape($value);	} else {
}	$returnhash->{&unescape($name)}=&unescape($value);
}	}
$ok_response = 1;	}
}	return 'ok';
}
if ($ok_response) {
return 'ok';
} else {
return $response;
}	}

	return $response;
}	}

sub auto_validate_class_sec {	sub auto_validate_class_sec {
Line 4794 sub modifyuser {	Line 5091 sub modifyuser {
if (($uhome eq 'no_host') &&	if (($uhome eq 'no_host') &&
(($umode && $upass) \|\| ($umode eq 'localauth'))) {	(($umode && $upass) \|\| ($umode eq 'localauth'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {	if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
$unhome=$env{'course.'.$env{'request.course.id'}.'.home'};	$unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
} else { # load balancing routine for determining $unhome	} else { # load balancing routine for determining $unhome
my $tryserver;
my $loadm=10000000;	my $loadm=10000000;
foreach $tryserver (keys %libserv) {	my %servers = &get_servers($udom,'library');
if ($hostdom{$tryserver} eq $udom) {	foreach my $tryserver (keys(%servers)) {
my $answer=reply('load',$tryserver);	my $answer=reply('load',$tryserver);
if (($answer=~/\d+/) && ($answer<$loadm)) {	if (($answer=~/\d+/) && ($answer<$loadm)) {
$loadm=$answer;	$loadm=$answer;
$unhome=$tryserver;	$unhome=$tryserver;
}	}
}
}	}
}	}
if (($unhome eq '') \|\| ($unhome eq 'no_host')) {	if (($unhome eq '') \|\| ($unhome eq 'no_host')) {
Line 4841 sub modifyuser {	Line 5136 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 4863 sub modifyuser {	Line 5159 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 5023 sub createcourse {	Line 5321 sub createcourse {
}	}
# ------------------------------------------------ Check supplied server name	# ------------------------------------------------ Check supplied server name
$course_server = $env{'user.homeserver'} if (! defined($course_server));	$course_server = $env{'user.homeserver'} if (! defined($course_server));
if (! exists($libserv{$course_server})) {	if (! &is_library($course_server)) {
return 'error:bad server name '.$course_server;	return 'error:bad server name '.$course_server;
}	}
# ------------------------------------------------------------- Make the course	# ------------------------------------------------------------- Make the course
Line 5159 sub save_selected_files {	Line 5457 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 5556 sub dirlist {	Line 5854 sub dirlist {
return @listing_results;	return @listing_results;
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!defined($alternateDirectoryRoot)) {
my %allusers;	my %allusers;
foreach my $tryserver (keys(%libserv)) {	my %servers = &get_servers($udom,'library');
if($hostdom{$tryserver} eq $udom) {	foreach my $tryserver (keys(%servers)) {
my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.	my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);	$udom, $tryserver);
my @listing_results;	my @listing_results;
if ($listing eq 'unknown_cmd') {	if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.	$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);	$udom, $tryserver);
@listing_results = split(/:/,$listing);	@listing_results = split(/:/,$listing);
} else {	} else {
@listing_results =	@listing_results =
map { &unescape($_); } split(/:/,$listing);	map { &unescape($_); } split(/:/,$listing);
}	}
if ($listing_results[0] ne 'no_such_dir' &&	if ($listing_results[0] ne 'no_such_dir' &&
$listing_results[0] ne 'empty' &&	$listing_results[0] ne 'empty' &&
$listing_results[0] ne 'con_lost') {	$listing_results[0] ne 'con_lost') {
foreach my $line (@listing_results) {	foreach my $line (@listing_results) {
my ($entry) = split(/&/,$line,2);	my ($entry) = split(/&/,$line,2);
$allusers{$entry} = 1;	$allusers{$entry} = 1;
}	}
}	}
}
}	}
my $alluserstr='';	my $alluserstr='';
foreach my $user (sort(keys(%allusers))) {	foreach my $user (sort(keys(%allusers))) {
Line 5589 sub dirlist {	Line 5886 sub dirlist {
return ('missing user name');	return ('missing user name');
}	}
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!defined($alternateDirectoryRoot)) {
my $tryserver;	my @all_domains = sort(&all_domains());
my %alldom=();	foreach my $domain (@all_domains) {
foreach $tryserver (keys(%libserv)) {	$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
$alldom{$hostdom{$tryserver}}=1;	}
}	return @all_domains;
my $alldomstr='';	} else {
foreach my $domain (sort(keys(%alldom))) {
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
}
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
} else {
return ('missing domain');	return ('missing domain');
}	}
}	}
Line 5758 sub devalidatecourseresdata {	Line 6049 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 5816 sub get_userresdata {	Line 6114 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 6163 sub packages_tab_default {	Line 6475 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 6379 sub metadata {	Line 6692 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 6881 sub getCODE {	Line 7199 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 7085 sub setup_random_from_rndseed {	Line 7402 sub setup_random_from_rndseed {
}	}

sub latest_receipt_algorithm_id {	sub latest_receipt_algorithm_id {
return 'receipt2';	return 'receipt3';
}	}

sub recunique {	sub recunique {
my $fucourseid=shift;	my $fucourseid=shift;
my $unique;	my $unique;
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$unique=$env{"course.$fucourseid.internal.encseed"};	$unique=$env{"course.$fucourseid.internal.encseed"};
} else {	} else {
$unique=$perlvar{'lonReceipt'};	$unique=$perlvar{'lonReceipt'};
Line 7102 sub recunique {	Line 7420 sub recunique {
sub recprefix {	sub recprefix {
my $fucourseid=shift;	my $fucourseid=shift;
my $prefix;	my $prefix;
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'\|\|
	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$prefix=$env{"course.$fucourseid.internal.encpref"};	$prefix=$env{"course.$fucourseid.internal.encpref"};
} else {	} else {
$prefix=$perlvar{'lonHostID'};	$prefix=$perlvar{'lonHostID'};
Line 7112 sub recprefix {	Line 7431 sub recprefix {

sub ireceipt {	sub ireceipt {
my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;	my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;

	my $return =&recprefix($fucourseid).'-';

	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' \|\|
	$env{'request.state'} eq 'construct') {
	$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
	return $return;
	}

my $cuname=unpack("%32C*",$funame);	my $cuname=unpack("%32C*",$funame);
my $cudom=unpack("%32C*",$fudom);	my $cudom=unpack("%32C*",$fudom);
my $cucourseid=unpack("%32C*",$fucourseid);	my $cucourseid=unpack("%32C*",$fucourseid);
my $cusymb=unpack("%32C*",$fusymb);	my $cusymb=unpack("%32C*",$fusymb);
my $cunique=&recunique($fucourseid);	my $cunique=&recunique($fucourseid);
my $cpart=unpack("%32S*",$part);	my $cpart=unpack("%32S*",$part);
my $return =&recprefix($fucourseid).'-';	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$env{'request.state'} eq 'construct') {
#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));	#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));

$return.= ($cunique%$cuname+	$return.= ($cunique%$cuname+
Line 7252 sub repcopy_userfile {	Line 7579 sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }	if (-e $transferfile) { return 'ok'; }
my $request;	my $request;
$uri=~s/^\///;	$uri=~s/^\///;
$request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);	$request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);	my $response=$ua->request($request,$transferfile);
# did it work?	# did it work?
if ($response->is_error()) {	if ($response->is_error()) {
Line 7275 sub tokenwrapper {	Line 7602 sub tokenwrapper {
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'};
} else {	} else {
Line 7290 sub tokenwrapper {	Line 7617 sub tokenwrapper {
sub getuploaded {	sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;	$uri=~s/^\///;
$uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;	$uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=$ua->request($request);
Line 7325 sub filelocation {	Line 7652 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 7345 sub filelocation {	Line 7673 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 7380 sub hreflocation {	Line 7710 sub hreflocation {
}	}

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();
while( my($id, $name) = each(%hostname)) {	while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");	# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {	if ($hostname eq $name) {
push(@domains,$hostdom{$id});	push(@domains,&host_domain($id));
}	}
}	}
return @domains;	return @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;
while( my($id, $name) = each(%hostname)) {	my %name_to_host = &all_names();
# &logthis("-$id-$name-$hostname-");	if (ref($name_to_host{$hostname}) eq 'ARRAY') {
if ($hostname eq $name) {	return @{ $name_to_host{$hostname} };
push(@ids,$id);
}
}	}
return @ids;	return;
}	}

sub additional_machine_domains {	sub additional_machine_domains {
Line 7444 sub declutter {	Line 7782 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 7513 sub correct_line_ends {	Line 7852 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;	sub parse_domain_tab {
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {	my ($lines) = @_;
while (my $line = <$fh>) {	foreach my $line (@$lines) {
next if ($line =~ /^(\#\|\s*$)/);	next if ($line =~ /^(\#\|\s*$ )/x);
# next if /^\#/;
chomp $line;	chomp($line);
my ($domain, $domain_description, $def_auth, $def_auth_arg,	my ($name,@elements) = split(/:/,$line,9);
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);	my %this_domain;
$domain_auth_def{$domain}=$def_auth;	foreach my $field ('description', 'auth_def', 'auth_arg_def',
$domain_auth_arg_def{$domain}=$def_auth_arg;	'lang_def', 'city', 'longi', 'lati',
$domaindescription{$domain}=$domain_description;	'primary') {
$domain_lang_def{$domain}=$def_lang;	$this_domain{$field} = shift(@elements);
$domain_city{$domain}=$city;	}
$domain_longi{$domain}=$longi;	$domain{$name} = \%this_domain;
$domain_lati{$domain}=$lati;	}
$domain_primary{$domain}=$primary;	}

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	sub reset_domain_info {
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	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};
}	}
close ($fh);
}	}


# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file
{	{
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	my %hostname;
	my %hostdom;
	my %libserv;
	my $loaded;
	my %name_to_host;

	sub parse_hosts_tab {
	my ($file) = @_;
	foreach my $configline (@$file) {
	next if ($configline =~ /^(\#\|\s*$ )/x);
	next if ($configline =~ /^\^/);
	chomp($configline);
	my ($id,$domain,$role,$name)=split(/:/,$configline);
	$name=~s/\s//g;
	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);
	}

while (my $configline=<$config>) {	sub load_hosts_tab {
next if ($configline =~ /^(\#\|\s*$)/);	my ($ignore_cache) = @_;
chomp($configline);	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
my ($id,$domain,$role,$name)=split(/:/,$configline);	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
$name=~s/\s//g;	my @config = <$config>;
if ($id && $domain && $role && $name) {	&parse_hosts_tab(\@config);
$hostname{$id}=$name;	close($config);
$hostdom{$id}=$domain;	$loaded=1;
if ($role eq 'library') { $libserv{$id}=$name; }	}
}
	sub hostname {
	&load_hosts_tab() if (!$loaded);

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

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

	return %hostname;
	}

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

	return %name_to_host;
	}

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

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

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

	return %libserv;
	}

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

	my ($domain,$type) = @_;
	my %possible_hosts = ($type eq 'library') ? %libserv
	: %hostname;
	my %result;
	if (ref($domain) eq 'ARRAY') {
	while ( my ($host,$hostname) = each(%possible_hosts)) {
	if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
	$result{$host} = $hostname;
	}
	}
	} else {
	while ( my ($host,$hostname) = each(%possible_hosts)) {
	if ($hostdom{$host} eq $domain) {
	$result{$host} = $hostname;
	}
	}
	}
	return %result;
	}

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

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

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

	my %seen;
	my @uniq = grep(!$seen{$_}++, values(%hostdom));
	return @uniq;
}	}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();
}	}

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

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

	sub get_host_ip {
	my ($lonid) = @_;
	if (exists($lonid_to_ip{$lonid})) {
	return $lonid_to_ip{$lonid};
	}
	my $name=&hostname($lonid);
	my $ip = gethostbyname($name);
	return if (!$ip \|\| length($ip) ne 4);
	$ip=inet_ntoa($ip);
	$name_to_ip{$name} = $ip;
	$lonid_to_ip{$lonid} = $ip;
	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 7942 X<userenvironment()>	Line 8509 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 7971 explanation of a user role term	Line 8548 explanation of a user role term

=item *	=item *

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

=head2 User Modification	=head2 User Modification
Line 8114 setting for a specific $type, where $typ	Line 8703 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 8395 critical subroutine	Line 8992 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)

=back	=back

Line 8793 symblist($mapname,%newhash) : update sym	Line 9393 symblist($mapname,%newhash) : update sym
=back	=back

=cut	=cut

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

Removed from v.1.833
changed lines
	Added in v.1.899