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.823 and 1.858

version 1.823, 2007/01/12 22:14:28	version 1.858, 2007/04/03 17:51:50
Line 35 use HTTP::Headers;	Line 35 use HTTP::Headers;
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	# use Date::Parse;
use vars	use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom	qw(%perlvar %badServerCache %spareid
%libserv %pr %prp $memcache %packagetab	%pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
%domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
$tmpdir $_64bit %env);	$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
Line 146 sub logperm {	Line 144 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($lonid))."\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 172 sub subreply {	Line 184 sub subreply {
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 203 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 215 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {	sub reconlonc {
my $peerfile=shift;	&logthis("Trying to reconnect lonc");
&logthis("Trying to reconnect for $peerfile");
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 224 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 238 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 367 sub transfer_profile_to_env {	Line 374 sub transfer_profile_to_env {
}	}
}	}

	sub timed_flock {
	my ($file,$lock_type) = @_;
	my $failed=0;
	eval {
	local $SIG{__DIE__}='DEFAULT';
	local $SIG{ALRM}=sub {
	$failed=1;
	die("failed lock");
	};
	alarm(13);
	flock($file,$lock_type);
	alarm(0);
	};
	if ($failed) {
	return undef;
	} else {
	return 1;
	}
	}

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment

sub appenv {	sub appenv {
Line 381 sub appenv {	Line 408 sub appenv {
$env{$key}=$newenv{$key};	$env{$key}=$newenv{$key};
}	}
}	}
if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),	open(my $env_file,$env{'user.environment'});
0640)) {	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)) {	while (my ($key,$value) = each(%newenv)) {
$disk_env{$key} = $value;	$disk_env{$key} = $value;
}	}
Line 399 sub delenv {	Line 429 sub delenv {
"Attempt to delete from environment ".$delthis);	"Attempt to delete from environment ".$delthis);
return 'error';	return 'error';
}	}
if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),	open(my $env_file,$env{'user.environment'});
0640)) {	if (&timed_flock($env_file,LOCK_EX)
	&&
	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
	(&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});
Line 498 sub spareserver {	Line 531 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 589 sub authenticate {	Line 622 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 615 sub homeserver {	Line 654 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 637 sub idget {	Line 677 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 703 sub get_dom {	Line 741 sub get_dom {
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if (!$udom) { $udom=$env{'user.domain'}; }	if (!$udom) { $udom=$env{'user.domain'}; }
if (exists($domain_primary{$udom})) {	if (defined(&domain($udom,'primary'))) {
my $uhome=$domain_primary{$udom};	my $uhome=&domain($udom,'primary');
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);	my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
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) {
Line 727 sub get_dom {	Line 765 sub get_dom {
sub put_dom {	sub put_dom {
my ($namespace,$storehash,$udom)=@_;	my ($namespace,$storehash,$udom)=@_;
if (!$udom) { $udom=$env{'user.domain'}; }	if (!$udom) { $udom=$env{'user.domain'}; }
if (exists($domain_primary{$udom})) {	if (defined(&domain($udom,'primary'))) {
my $uhome=$domain_primary{$udom};	my $uhome=&domain($udom,'primary');
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 740 sub put_dom {	Line 778 sub put_dom {
}	}
}	}

	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);
	}

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

sub assign_access_key {	sub assign_access_key {
Line 964 my %remembered;	Line 1026 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) > 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 975 sub devalidate_cache_new {	Line 1043 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 998 sub is_cached_new {	Line 1066 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 1176 sub repcopy {	Line 1244 sub repcopy {
}	}
$filename=~s/[\n\r]//g;	$filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";	my $transname="$filename.in.transfer";
	# FIXME: this should flock
if ((-e $filename) \|\| (-e $transname)) { return 'ok'; }	if ((-e $filename) \|\| (-e $transname)) { return 'ok'; }
my $remoteurl=subscribe($filename);	my $remoteurl=subscribe($filename);
if ($remoteurl =~ /^con_lost by/) {	if ($remoteurl =~ /^con_lost by/) {
Line 1424 sub store_edited_file {	Line 1493 sub store_edited_file {
}	}

sub clean_filename {	sub clean_filename {
my ($fname)=@_;	my ($fname,$args)=@_;
# Replace Windows backslashes by forward slashes	# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;	$fname=~s/\\/\//g;
# Get rid of everything but the actual filename	if (!$args->{'keep_path'}) {
$fname=~s/^.*\/([^\/]+)$/$1/;	# Get rid of everything but the actual filename
	$fname=~s/^.*\/([^\/]+)$/$1/;
	}
# Replace spaces by underscores	# Replace spaces by underscores
$fname=~s/\s+/\_/g;	$fname=~s/\s+/\_/g;
# Replace all other weird characters by nothing	# Replace all other weird characters by nothing
$fname=~s/[^\w\.\-]//g;	$fname=~s{[^/\w\.\-]}{}g;
# Replace all .\d. sequences with _\d. so they no longer look like version	# Replace all .\d. sequences with _\d. so they no longer look like version
# numbers	# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;	$fname=~s/\.(\d+)(?=\.)/_$1/g;
Line 1445 sub clean_filename {	Line 1516 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
	#
# 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

Line 1564 sub finishuserfileupload {	Line 1639 sub finishuserfileupload {
' for embedded media: '.$parse_result);	' for embedded media: '.$parse_result);
}	}
}	}

# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
my $docuhome=&homeserver($docuname,$docudom);	my $docuhome=&homeserver($docuname,$docudom);
Line 1576 sub finishuserfileupload {	Line 1652 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 1790 sub flushcourselogs {	Line 1866 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 1858 sub flushcourselogs {	Line 1935 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 1998 sub get_course_adv_roles {	Line 2074 sub get_course_adv_roles {
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom)=@_;	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 ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }	my $status = 'active';
if (($tstart) && ($now<$tstart)) { next; }	if (($tend) && ($tend<$now)) {
	$status = 'previous';
	}
	if (($tstart) && ($now<$tstart)) {
	$status = 'future';
	}
	if (ref($types) eq 'ARRAY') {
	if (!grep(/^\Q$status\E$/,@{$types})) {
	next;
	}
	} else {
	if ($status ne 'active') {
	next;
	}
	}
my ($role,$username,$domain,$section)=split(/\:/,$entry);	my ($role,$username,$domain,$section)=split(/\:/,$entry);
	if (ref($roledoms) eq 'ARRAY') {
	if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
	next;
	}
	}
	if (ref($roles) eq 'ARRAY') {
	if (!grep(/^\Q$role\E$/,@{$roles})) {
	next;
	}
	}
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}	}
return %returnhash;	return %returnhash;
}	}

Line 2022 sub get_my_roles {	Line 2127 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 2058 sub courseiddump {	Line 2163 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 2090 sub dcmailput {	Line 2200 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 2116 sub get_domain_roles {	Line 2227 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 2218 sub checkin {	Line 2329 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 2887 sub custom_roleprivs {	Line 2998 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 4095 sub definerole {	Line 4206 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 4118 sub log_query {	Line 4230 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 4150 sub fetch_enrollment_query {	Line 4262 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 4247 sub courselog_query {	Line 4359 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 4341 sub auto_photochoice {	Line 4459 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 4381 sub auto_instcode_format {	Line 4499 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 4420 sub auto_instcode_format {	Line 4537 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 4741 sub modifyuser {	Line 4854 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 4970 sub createcourse {	Line 5081 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 5081 sub is_locked {	Line 5192 sub is_locked {

sub declutter_portfile {	sub declutter_portfile {
my ($file) = @_;	my ($file) = @_;
&logthis("got $file");	$file =~ s{^(/portfolio/\|portfolio/)}{/};
$file =~ s-^(/portfolio/\|portfolio/)-/-;
&logthis("ret $file");
return $file;	return $file;
}	}

Line 5316 sub modify_access_controls {	Line 5425 sub modify_access_controls {
return ($outcome,$deloutcome,\%new_values,\%translation);	return ($outcome,$deloutcome,\%new_values,\%translation);
}	}

	sub make_public_indefinitely {
	my ($requrl) = @_;
	my $now = time;
	my $action = 'activate';
	my $aclnum = 0;
	if (&is_portfolio_url($requrl)) {
	my (undef,$udom,$unum,$file_name,$group) =
	&parse_portfolio_url($requrl);
	my $current_perms = &get_portfile_permissions($udom,$unum);
	my %access_controls = &get_access_controls($current_perms,
	$group,$file_name);
	foreach my $key (keys(%{$access_controls{$file_name}})) {
	my ($num,$scope,$end,$start) =
	($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);
	if ($scope eq 'public') {
	if ($start <= $now && $end == 0) {
	$action = 'none';
	} else {
	$action = 'update';
	$aclnum = $num;
	}
	last;
	}
	}
	if ($action eq 'none') {
	return 'ok';
	} else {
	my %changes;
	my $newend = 0;
	my $newstart = $now;
	my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
	$changes{$action}{$newkey} = {
	type => 'public',
	time => {
	start => $newstart,
	end => $newend,
	},
	};
	my ($outcome,$deloutcome,$new_values,$translation) =
	&modify_access_controls($file_name,\%changes,$udom,$unum);
	return $outcome;
	}
	} else {
	return 'invalid';
	}
	}

#------------------------------------------------------Get Marked as Read Only	#------------------------------------------------------Get Marked as Read Only

sub get_marked_as_readonly {	sub get_marked_as_readonly {
Line 5458 sub dirlist {	Line 5614 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 5491 sub dirlist {	Line 5646 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 6065 sub packages_tab_default {	Line 6214 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) {
	# 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 6783 sub getCODE {	Line 6933 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 (!$symb) {
unless ($symb=$wsymb) { return time; }	unless ($symb=$wsymb) { return time; }
Line 6987 sub setup_random_from_rndseed {	Line 7136 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 7004 sub recunique {	Line 7154 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 7014 sub recprefix {	Line 7165 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 7111 sub repcopy_userfile {	Line 7270 sub repcopy_userfile {
if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return 'ok'; }	if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return 'ok'; }
my ($cdom,$cnum,$filename) =	my ($cdom,$cnum,$filename) =
($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)\|);	($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)\|);
my ($info,$rtncode);
my $uri="/uploaded/$cdom/$cnum/$filename";	my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {	if (-e "$file") {
	# we already have a local copy, check it out
my @fileinfo = stat($file);	my @fileinfo = stat($file);
	my $rtncode;
	my $info;
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {	if ($lwpresp ne 'ok') {
	# there is no such file anymore, even though we had a local copy
if ($rtncode eq '404') {	if ($rtncode eq '404') {
unlink($file);	unlink($file);
}	}
#my $ua=new LWP::UserAgent;
#my $request=new HTTP::Request('GET',&tokenwrapper($uri));
#my $response=$ua->request($request);
#if ($response->is_success()) {
# return $response->content;
# } else {
# return -1;
# }
return -1;	return -1;
}	}
if ($info < $fileinfo[9]) {	if ($info < $fileinfo[9]) {
	# nice, the file we have is up-to-date, just say okay
return 'ok';	return 'ok';
	} else {
	# the file is outdated, get rid of it
	unlink($file);
}	}
$info = '';	}
$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);	# one way or the other, at this point, we don't have the file
if ($lwpresp ne 'ok') {	# construct the correct path for the file
return -1;	my @parts = ($cdom,$cnum);
}	if ($filename =~ m\|^(.+)/[^/]+$\|) {
} else {	push @parts, split(/\//,$1);
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);	}
if ($lwpresp ne 'ok') {	my $path = $perlvar{'lonDocRoot'}.'/userfiles';
my $ua=new LWP::UserAgent;	foreach my $part (@parts) {
my $request=new HTTP::Request('GET',&tokenwrapper($uri));	$path .= '/'.$part;
my $response=$ua->request($request);	if (!-e $path) {
if ($response->is_success()) {	mkdir($path,0770);
$info=$response->content;
} else {
return -1;
}
}
my @parts = ($cdom,$cnum);
if ($filename =~ m\|^(.+)/[^/]+$\|) {
push @parts, split(/\//,$1);
}
my $path = $perlvar{'lonDocRoot'}.'/userfiles';
foreach my $part (@parts) {
$path .= '/'.$part;
if (!-e $path) {
mkdir($path,0770);
}
}	}
}	}
open(FILE,">$file");	# now the path exists for sure
print FILE $info;	# get a user agent
close(FILE);	my $ua=new LWP::UserAgent;
	my $transferfile=$file.'.in.transfer';
	# FIXME: this should flock
	if (-e $transferfile) { return 'ok'; }
	my $request;
	$uri=~s/^\///;
	$request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
	my $response=$ua->request($request,$transferfile);
	# did it work?
	if ($response->is_error()) {
	unlink($transferfile);
	&logthis("Userfile repcopy failed for $uri");
	return -1;
	}
	# worked, rename the transfer file
	rename($transferfile,$file);
return 'ok';	return 'ok';
}	}

Line 7178 sub tokenwrapper {	Line 7336 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 7186 sub tokenwrapper {	Line 7344 sub tokenwrapper {
}	}
}	}

	# call with reqtype HEAD: get last modification time
	# call with reqtype GET: get the file contents
	# Do not call this with reqtype GET for large files! It loads everything into memory
	#
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 7279 sub hreflocation {	Line 7441 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;
	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) {
Line 7302 sub current_machine_ids {	Line 7475 sub current_machine_ids {
return @ids;	return @ids;
}	}

	sub additional_machine_domains {
	my @domains;
	open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
	while( my $line = <$fh>) {
	$line =~ s/\s//g;
	push(@domains,$line);
	}
	return @domains;
	}

	sub default_login_domain {
	my $domain = $perlvar{'lonDefDomain'};
	my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
	foreach my $posdom (&current_machine_domains(),
	&additional_machine_domains()) {
	if (lc($posdom) eq lc($testdomain)) {
	$domain=$posdom;
	last;
	}
	}
	return $domain;
	}

# ------------------------------------------------------------- Declutters URLs	# ------------------------------------------------------------- Declutters URLs

sub declutter {	sub declutter {
Line 7408 sub goodbye {	Line 7604 sub goodbye {
}	}

BEGIN {	BEGIN {

# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
Line 7415 BEGIN {	Line 7612 BEGIN {
%perlvar = (%perlvar,%{$configvars});	%perlvar = (%perlvar,%{$configvars});
}	}

	sub get_dns {
	my ($url,$func) = @_;
	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
	foreach my $dns (<$config>) {
	next if ($dns !~ /^\^(\S*)/x);
	$dns = $1;
	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);
	&$func(\@content);
	}
	close($config);
	}
# ------------------------------------------------------------ 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;	&logthis("Domain.tab: $name ".$domain{$name}{'description'} );
$domain_primary{$domain}=$primary;	}
	}

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

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

	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;
	$hostdom{$id}=$domain;
	if ($role eq 'library') { $libserv{$id}=$name; }
	}
	&logthis("Hosts.tab: $name ".$id );
	}
	}

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

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

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

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

	return %hostname;
	}

	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;
	}
}	}

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};	sub get_hosts_from_ip {
my $ip;	my ($ip) = @_;
if (!exists($name_to_ip{$name})) {	my %iphosts = &get_iphost();
$ip = gethostbyname($name);	if (ref($iphosts{$ip})) {
if (!$ip \|\| length($ip) ne 4) {	return @{$iphosts{$ip}};
&logthis("Skipping host $id name $name no IP found\n");	}
next;	return;
	}

	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 {
	if (%iphost) { return %iphost; }
	my %hostname = &all_hostnames();
	foreach my $id (keys(%hostname)) {
	my $name=$hostname{$id};
	my $ip;
	if (!exists($name_to_ip{$name})) {
	$ip = gethostbyname($name);
	if (!$ip \|\| length($ip) ne 4) {
	&logthis("Skipping host $id name $name no IP found");
	next;
	}
	$ip=inet_ntoa($ip);
	$name_to_ip{$name} = $ip;
	} else {
	$ip = $name_to_ip{$name};
}	}
$ip=inet_ntoa($ip);	$lonid_to_ip{$id} = $ip;
$name_to_ip{$name} = $ip;	push(@{$iphost{$ip}},$id);
} else {
$ip = $name_to_ip{$name};
}	}
push(@{$iphost{$ip}},$id);	return %iphost;
}	}
return %iphost;
}	}

# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
Line 7818 X<userenvironment()>	Line 8157 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 7845 and course level	Line 8188 and course level
plaintext($short) : return value in %prp hash (rolesplain.tab); plain text	plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
explanation of a user role term	explanation of a user role term

	=item *

	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

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

Removed from v.1.823
changed lines
	Added in v.1.858