version 1.775, 2006/08/30 21:48:54
|
version 1.782.2.4, 2006/10/20 20:39:44
|
Line 293 sub error {
|
Line 293 sub error {
|
} |
} |
|
|
# ------------------------------------------- Transfer profile into environment |
# ------------------------------------------- Transfer profile into environment |
|
my $env_loaded; |
sub transfer_profile_to_env { |
sub transfer_profile_to_env { |
my ($lonidsdir,$handle)=@_; |
my ($lonidsdir,$handle,$force_transfer) = @_; |
|
if (!$force_transfer && $env_loaded) { return; } |
|
|
if (!defined($lonidsdir)) { |
if (!defined($lonidsdir)) { |
$lonidsdir = $perlvar{'lonIDsDir'}; |
$lonidsdir = $perlvar{'lonIDsDir'}; |
} |
} |
Line 325 sub transfer_profile_to_env {
|
Line 327 sub transfer_profile_to_env {
|
} |
} |
} |
} |
$env{'user.environment'} = "$lonidsdir/$handle.id"; |
$env{'user.environment'} = "$lonidsdir/$handle.id"; |
|
$env_loaded=1; |
foreach my $expired_key (keys(%Remove)) { |
foreach my $expired_key (keys(%Remove)) { |
&delenv($expired_key); |
&delenv($expired_key); |
} |
} |
Line 344 sub appenv {
|
Line 347 sub appenv {
|
$env{$key}=$newenv{$key}; |
$env{$key}=$newenv{$key}; |
} |
} |
} |
} |
|
foreach my $key (keys(%newenv)) { |
|
my $value = &escape($newenv{$key}); |
|
delete($newenv{$key}); |
|
$newenv{&escape($key)}=$value; |
|
} |
|
|
my $lockfh; |
my $lockfh; |
unless (open($lockfh,"$env{'user.environment'}")) { |
unless (open($lockfh,"$env{'user.environment'}")) { |
Line 369 sub appenv {
|
Line 377 sub appenv {
|
chomp($oldenv[$i]); |
chomp($oldenv[$i]); |
if ($oldenv[$i] ne '') { |
if ($oldenv[$i] ne '') { |
my ($name,$value)=split(/=/,$oldenv[$i],2); |
my ($name,$value)=split(/=/,$oldenv[$i],2); |
$name=&unescape($name); |
|
$value=&unescape($value); |
|
unless (defined($newenv{$name})) { |
unless (defined($newenv{$name})) { |
$newenv{$name}=$value; |
$newenv{$name}=$value; |
} |
} |
Line 383 sub appenv {
|
Line 389 sub appenv {
|
} |
} |
my $newname; |
my $newname; |
foreach $newname (keys %newenv) { |
foreach $newname (keys %newenv) { |
print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; |
print $fh $newname.'='.$newenv{$newname}."\n"; |
} |
} |
close($fh); |
close($fh); |
} |
} |
Line 493 sub overloaderror {
|
Line 499 sub overloaderror {
|
|
|
sub spareserver { |
sub spareserver { |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my $tryserver; |
my $spare_server; |
my $spareserver=''; |
|
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
my $lowestserver=$loadpercent > $userloadpercent? |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
$loadpercent : $userloadpercent; |
: $userloadpercent; |
foreach $tryserver (keys(%spareid)) { |
|
my $loadans=&reply('load',$tryserver); |
foreach my $try_server (@{ $spareid{'primary'} }) { |
my $userloadans=&reply('userload',$tryserver); |
($spare_server, $lowest_load) = |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
&compare_server_load($try_server, $spare_server, $lowest_load); |
next; #didn't get a number from the server |
} |
} |
|
my $answer; |
my $found_server = ($spare_server ne '' && $lowest_load < 100); |
if ($loadans =~ /\d/) { |
|
if ($userloadans =~ /\d/) { |
if (!$found_server) { |
#both are numbers, pick the bigger one |
foreach my $try_server (@{ $spareid{'default'} }) { |
$answer=$loadans > $userloadans? |
($spare_server, $lowest_load) = |
$loadans : $userloadans; |
&compare_server_load($try_server, $spare_server, $lowest_load); |
} else { |
|
$answer = $loadans; |
|
} |
|
} else { |
|
$answer = $userloadans; |
|
} |
|
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
|
if ($want_server_name) { |
|
$spareserver=$tryserver; |
|
} else { |
|
$spareserver="http://$hostname{$tryserver}"; |
|
} |
|
$lowestserver=$answer; |
|
} |
} |
} |
} |
return $spareserver; |
|
|
if (!$want_server_name) { |
|
$spare_server="http://$hostname{$spare_server}"; |
|
} |
|
return $spare_server; |
} |
} |
|
|
|
sub compare_server_load { |
|
my ($try_server, $spare_server, $lowest_load) = @_; |
|
|
|
my $loadans = &reply('load', $try_server); |
|
my $userloadans = &reply('userload',$try_server); |
|
|
|
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
|
next; #didn't get a number from the server |
|
} |
|
|
|
my $load; |
|
if ($loadans =~ /\d/) { |
|
if ($userloadans =~ /\d/) { |
|
#both are numbers, pick the bigger one |
|
$load = ($loadans > $userloadans) ? $loadans |
|
: $userloadans; |
|
} else { |
|
$load = $loadans; |
|
} |
|
} else { |
|
$load = $userloadans; |
|
} |
|
|
|
if (($load =~ /\d/) && ($load < $lowest_load)) { |
|
$spare_server = $try_server; |
|
$lowest_load = $load; |
|
} |
|
return ($spare_server,$lowest_load); |
|
} |
# --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
|
|
sub changepass { |
sub changepass { |
Line 891 sub save_cache {
|
Line 916 sub save_cache {
|
&purge_remembered(); |
&purge_remembered(); |
#&Apache::loncommon::validate_page(); |
#&Apache::loncommon::validate_page(); |
undef(%env); |
undef(%env); |
|
undef($env_loaded); |
} |
} |
|
|
my $to_remember=-1; |
my $to_remember=-1; |
Line 1176 sub ssi_body {
|
Line 1202 sub ssi_body {
|
} |
} |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
&ssi($filelink,%form)); |
&ssi($filelink,%form)); |
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs; |
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs; |
$output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
return $output; |
return $output; |
Line 1184 sub ssi_body {
|
Line 1210 sub ssi_body {
|
|
|
# --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
|
|
|
sub absolute_url { |
|
my ($host_name) = @_; |
|
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); |
|
if ($host_name eq '') { |
|
$host_name = $ENV{'SERVER_NAME'}; |
|
} |
|
return $protocol.$host_name; |
|
} |
|
|
sub ssi { |
sub ssi { |
|
|
my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
Line 1195 sub ssi {
|
Line 1230 sub ssi {
|
$form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
|
|
if (%form) { |
if (%form) { |
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('POST',&absolute_url().$fn); |
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
} else { |
} else { |
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('GET',&absolute_url().$fn); |
} |
} |
|
|
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
Line 4074 sub auto_run {
|
Line 4109 sub auto_run {
|
my $response = &reply('autorun:'.$cdom,$homeserver); |
my $response = &reply('autorun:'.$cdom,$homeserver); |
return $response; |
return $response; |
} |
} |
|
|
sub auto_get_sections { |
sub auto_get_sections { |
my ($cnum,$cdom,$inst_coursecode) = @_; |
my ($cnum,$cdom,$inst_coursecode) = @_; |
my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
Line 4085 sub auto_get_sections {
|
Line 4120 sub auto_get_sections {
|
} |
} |
return @secs; |
return @secs; |
} |
} |
|
|
sub auto_new_course { |
sub auto_new_course { |
my ($cnum,$cdom,$inst_course_id,$owner) = @_; |
my ($cnum,$cdom,$inst_course_id,$owner) = @_; |
my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); |
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); |
return $response; |
return $response; |
} |
} |
|
|
sub auto_validate_courseID { |
sub auto_validate_courseID { |
my ($cnum,$cdom,$inst_course_id) = @_; |
my ($cnum,$cdom,$inst_course_id) = @_; |
my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); |
my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); |
return $response; |
return $response; |
} |
} |
|
|
sub auto_create_password { |
sub auto_create_password { |
my ($cnum,$cdom,$authparam) = @_; |
my ($cnum,$cdom,$authparam) = @_; |
my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
Line 4231 sub auto_instcode_format {
|
Line 4266 sub auto_instcode_format {
|
} |
} |
} |
} |
|
|
sub autovalidateclass_sec { |
sub auto_validate_class_sec { |
my ($cdom,$cnum,$owner,$inst_class) = @_; |
my ($cdom,$cnum,$owner,$inst_class) = @_; |
my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. |
my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. |
Line 7110 BEGIN {
|
Line 7145 BEGIN {
|
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
unless ($readit) { |
unless ($readit) { |
{ |
{ |
# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block |
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
open(my $config,"</etc/httpd/conf/loncapa.conf"); |
%perlvar = (%perlvar,%{$configvars}); |
|
|
while (my $configline=<$config>) { |
|
if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { |
|
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
chomp($varvalue); |
|
$perlvar{$varname}=$varvalue; |
|
} |
|
} |
|
close($config); |
|
} |
|
{ |
|
open(my $config,"</etc/httpd/conf/loncapa_apache.conf"); |
|
|
|
while (my $configline=<$config>) { |
|
if ($configline =~ /^[^\#]*PerlSetVar/) { |
|
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
chomp($varvalue); |
|
$perlvar{$varname}=$varvalue; |
|
} |
|
} |
|
close($config); |
|
} |
} |
|
|
# ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
Line 7214 sub get_iphost {
|
Line 7228 sub get_iphost {
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
if ($configline) { |
if ($configline) { |
$spareid{$configline}=1; |
my ($host,$type) = split(':',$configline,2); |
|
if (!defined($type) || $type eq '') { $type = 'default' }; |
|
push(@{ $spareid{$type} }, $host); |
} |
} |
} |
} |
close($config); |
close($config); |
Line 7276 sub get_iphost {
|
Line 7292 sub get_iphost {
|
|
|
} |
} |
|
|
$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], |
|
'compress_threshold'=> 20_000, |
|
}); |
|
|
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$dumpcount=0; |
$dumpcount=0; |