version 1.1056.4.6, 2010/08/17 01:49:04
|
version 1.1056.4.11, 2010/10/01 14:26:07
|
Line 222 sub get_server_loncaparev {
|
Line 222 sub get_server_loncaparev {
|
my @ids=¤t_machine_ids(); |
my @ids=¤t_machine_ids(); |
if (grep(/^\Q$lonhost\E$/,@ids)) { |
if (grep(/^\Q$lonhost\E$/,@ids)) { |
$answer = $perlvar{'lonVersion'}; |
$answer = $perlvar{'lonVersion'}; |
if ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) { |
if ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { |
$loncaparev = $1; |
$loncaparev = $1; |
} |
} |
} else { |
} else { |
Line 230 sub get_server_loncaparev {
|
Line 230 sub get_server_loncaparev {
|
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { |
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { |
if ($caller eq 'loncron') { |
if ($caller eq 'loncron') { |
my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
$ua->timeout(20); |
$ua->timeout(4); |
my $protocol = $protocol{$lonhost}; |
my $protocol = $protocol{$lonhost}; |
$protocol = 'http' if ($protocol ne 'https'); |
$protocol = 'http' if ($protocol ne 'https'); |
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; |
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; |
Line 238 sub get_server_loncaparev {
|
Line 238 sub get_server_loncaparev {
|
my $response=$ua->request($request); |
my $response=$ua->request($request); |
unless ($response->is_error()) { |
unless ($response->is_error()) { |
my $content = $response->content; |
my $content = $response->content; |
if ($content =~ /<p>VERSION\:\s*([\d.\-]+)<\/p>/) { |
if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) { |
$loncaparev = $1; |
$loncaparev = $1; |
} |
} |
} |
} |
} else { |
} else { |
$loncaparev = $loncaparevs{$lonhost}; |
$loncaparev = $loncaparevs{$lonhost}; |
} |
} |
} elsif ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) { |
} elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { |
$loncaparev = $1; |
$loncaparev = $1; |
} |
} |
} |
} |
Line 756 sub spareserver {
|
Line 756 sub spareserver {
|
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
: $userloadpercent; |
: $userloadpercent; |
|
my ($uint_dom,$remotesessions); |
|
if ($env{'user.domain'}) { |
|
my $uprimary_id = &Apache::lonnet::domain($env{'user.domain'},'primary'); |
|
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
|
my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'}); |
|
$remotesessions = $udomdefaults{'remotesessions'}; |
|
} |
foreach my $try_server (@{ $spareid{'primary'} }) { |
foreach my $try_server (@{ $spareid{'primary'} }) { |
|
if ($uint_dom) { |
|
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
|
$remotesessions,$try_server)); |
|
} |
($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
&compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
} |
} |
Line 766 sub spareserver {
|
Line 776 sub spareserver {
|
|
|
if (!$found_server) { |
if (!$found_server) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
|
if ($uint_dom) { |
|
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
|
$remotesessions,$try_server)); |
|
} |
($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
&compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
} |
} |
Line 778 sub spareserver {
|
Line 792 sub spareserver {
|
} |
} |
if (defined($spare_server)) { |
if (defined($spare_server)) { |
my $hostname = &hostname($spare_server); |
my $hostname = &hostname($spare_server); |
if (defined($hostname)) { |
if (defined($hostname)) { |
$spare_server = $protocol.'://'.$hostname; |
$spare_server = $protocol.'://'.$hostname; |
} |
} |
} |
} |
Line 1014 sub can_host_session {
|
Line 1028 sub can_host_session {
|
return $canhost; |
return $canhost; |
} |
} |
|
|
|
sub spare_can_host { |
|
my ($udom,$uint_dom,$remotesessions,$try_server)=@_; |
|
my $canhost=1; |
|
my @intdoms; |
|
my $internet_names = &Apache::lonnet::get_internet_names($try_server); |
|
if (ref($internet_names) eq 'ARRAY') { |
|
@intdoms = @{$internet_names}; |
|
} |
|
unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { |
|
my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server); |
|
my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); |
|
my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom); |
|
my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server); |
|
$canhost = &can_host_session($udom,$try_server,$remoterev, |
|
$remotesessions, |
|
$defdomdefaults{'hostedsessions'}); |
|
} |
|
return $canhost; |
|
} |
|
|
# ---------------------- Find the homebase for a user from domain's lib servers |
# ---------------------- Find the homebase for a user from domain's lib servers |
|
|
my %homecache; |
my %homecache; |
Line 1723 sub getsection {
|
Line 1757 sub getsection {
|
# If there is a role which has expired, return it. |
# If there is a role which has expired, return it. |
# |
# |
$courseid = &courseid_to_courseurl($courseid); |
$courseid = &courseid_to_courseurl($courseid); |
my %roleshash = &dump('roles',$udom,$unam,$courseid); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
|
my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra); |
foreach my $key (keys(%roleshash)) { |
foreach my $key (keys(%roleshash)) { |
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
my $section=$1; |
my $section=$1; |
Line 3026 sub get_my_roles {
|
Line 3061 sub get_my_roles {
|
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
my (%dumphash,%nothide); |
my (%dumphash,%nothide); |
if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
%dumphash = &dump('roles',$udom,$uname); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
|
%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra); |
} else { |
} else { |
%dumphash= |
%dumphash= |
&dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
Line 4090 sub rolesinit {
|
Line 4126 sub rolesinit {
|
my ($domain,$username,$authhost)=@_; |
my ($domain,$username,$authhost)=@_; |
my $now=time; |
my $now=time; |
my %userroles = ('user.login.time' => $now); |
my %userroles = ('user.login.time' => $now); |
my $extra = &freeze_escape({'clientcheckrole' => 1}); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost); |
my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost); |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
($rolesdump =~ /^error:/)) { |
($rolesdump =~ /^error:/)) { |
Line 4441 sub del {
|
Line 4477 sub del {
|
# -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
|
|
sub dump { |
sub dump { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
Line 4450 sub dump {
|
Line 4486 sub dump {
|
} else { |
} else { |
$regexp='.'; |
$regexp='.'; |
} |
} |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome); |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
my %returnhash=(); |
my %returnhash=(); |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
Line 4995 sub is_portfolio_file {
|
Line 5031 sub is_portfolio_file {
|
} |
} |
|
|
sub usertools_access { |
sub usertools_access { |
my ($uname,$udom,$tool,$action,$context) = @_; |
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_; |
my ($access,%tools); |
my ($access,%tools); |
if ($context eq '') { |
if ($context eq '') { |
$context = 'tools'; |
$context = 'tools'; |
Line 5037 sub usertools_access {
|
Line 5073 sub usertools_access {
|
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
$inststatus = $env{'environment.inststatus'}; |
$inststatus = $env{'environment.inststatus'}; |
} else { |
} else { |
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); |
if (ref($userenvref) eq 'HASH') { |
$toolstatus = $userenv{$context.'.'.$tool}; |
$toolstatus = $userenvref->{$context.'.'.$tool}; |
$inststatus = $userenv{'inststatus'}; |
$inststatus = $userenvref->{'inststatus'}; |
|
} else { |
|
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); |
|
$toolstatus = $userenv{$context.'.'.$tool}; |
|
$inststatus = $userenv{'inststatus'}; |
|
} |
} |
} |
|
|
if ($toolstatus ne '') { |
if ($toolstatus ne '') { |
Line 5051 sub usertools_access {
|
Line 5092 sub usertools_access {
|
return $access; |
return $access; |
} |
} |
|
|
my $is_adv = &is_advanced_user($udom,$uname); |
my ($is_adv,%domdef); |
my %domdef = &get_domain_defaults($udom); |
if (ref($is_advref) eq 'HASH') { |
|
$is_adv = $is_advref->{'is_adv'}; |
|
} else { |
|
$is_adv = &is_advanced_user($udom,$uname); |
|
} |
|
if (ref($domdefref) eq 'HASH') { |
|
%domdef = %{$domdefref}; |
|
} else { |
|
%domdef = &get_domain_defaults($udom); |
|
} |
if (ref($domdef{$tool}) eq 'HASH') { |
if (ref($domdef{$tool}) eq 'HASH') { |
if ($is_adv) { |
if ($is_adv) { |
if ($domdef{$tool}{'_LC_adv'} ne '') { |
if ($domdef{$tool}{'_LC_adv'} ne '') { |
Line 5126 sub is_course_owner {
|
Line 5176 sub is_course_owner {
|
|
|
sub is_advanced_user { |
sub is_advanced_user { |
my ($udom,$uname) = @_; |
my ($udom,$uname) = @_; |
|
if ($udom ne '' && $uname ne '') { |
|
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
|
return $env{'user.adv'}; |
|
} |
|
} |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
my %allroles; |
my %allroles; |
my $is_adv; |
my $is_adv; |
Line 6411 sub get_users_groups {
|
Line 6466 sub get_users_groups {
|
} else { |
} else { |
$grouplist = ''; |
$grouplist = ''; |
my $courseurl = &courseid_to_courseurl($courseid); |
my $courseurl = &courseid_to_courseurl($courseid); |
my %roleshash = &dump('roles',$udom,$uname,$courseurl); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
|
my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra); |
my $access_end = $env{'course.'.$courseid. |
my $access_end = $env{'course.'.$courseid. |
'.default_enrollment_end_date'}; |
'.default_enrollment_end_date'}; |
my $now = time; |
my $now = time; |
Line 6914 sub modifyuser {
|
Line 6970 sub modifyuser {
|
if ($reply ne 'ok') { |
if ($reply ne 'ok') { |
return 'error: '.$reply; |
return 'error: '.$reply; |
} |
} |
|
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { |
|
&Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom); |
|
} |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
$logmsg = 'Success modifying user '.$logmsg; |
$logmsg = 'Success modifying user '.$logmsg; |