VERSION\:\s*([\d.\-]+)<\/p>/) { + if ($content =~ /
VERSION\:\s*([\w.\-]+)<\/p>/) { $loncaparev = $1; } } } else { $loncaparev = $loncaparevs{$lonhost}; } - } elsif ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) { + } elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { $loncaparev = $1; } } @@ -727,13 +727,23 @@ sub userload { # ------------------------------ Find server with least workload from spare.tab sub spareserver { - my ($loadpercent,$userloadpercent,$want_server_name) = @_; + my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_; my $spare_server; if ($userloadpercent !~ /\d/) { $userloadpercent=0; } my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent : $userloadpercent; - + my ($uint_dom,$remotesessions); + if (($udom ne '') && (&domain($udom) ne '')) { + my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); + $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); + my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); + $remotesessions = $udomdefaults{'remotesessions'}; + } foreach my $try_server (@{ $spareid{'primary'} }) { + if ($uint_dom) { + next unless (&spare_can_host($udom,$uint_dom,$remotesessions, + $try_server)); + } ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -742,6 +752,10 @@ sub spareserver { if (!$found_server) { foreach my $try_server (@{ $spareid{'default'} }) { + if ($uint_dom) { + next unless (&spare_can_host($udom,$uint_dom,$remotesessions, + $try_server)); + } ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -754,7 +768,7 @@ sub spareserver { } if (defined($spare_server)) { my $hostname = &hostname($spare_server); - if (defined($hostname)) { + if (defined($hostname)) { $spare_server = $protocol.'://'.$hostname; } } @@ -812,6 +826,27 @@ sub has_user_session { return 0; } +# --------- determine least loaded server in a user's domain which allows login + +sub choose_server { + my ($udom) = @_; + my %domconfhash = &Apache::loncommon::get_domainconf($udom); + my %servers = &get_servers($udom); + my $lowest_load = 30000; + my ($login_host,$hostname); + foreach my $lonhost (keys(%servers)) { + my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; + if ($loginvia eq '') { + ($login_host, $lowest_load) = + &compare_server_load($lonhost, $login_host, $lowest_load); + } + } + if ($login_host ne '') { + $hostname = $servers{$login_host}; + } + return ($login_host,$hostname); +} + # --------------------------------------------- Try to change a user's password sub changepass { @@ -969,6 +1004,26 @@ sub can_host_session { 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 my %homecache; @@ -1678,7 +1733,8 @@ sub getsection { # If there is a role which has expired, return it. # $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)) { next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; @@ -2980,8 +3036,9 @@ sub get_my_roles { unless (defined($uname)) { $uname=$env{'user.name'}; } unless (defined($udom)) { $udom=$env{'user.domain'}; } my (%dumphash,%nothide); - if ($context eq 'userroles') { - %dumphash = &dump('roles',$udom,$uname); + if ($context eq 'userroles') { + my $extra = &freeze_escape({'skipcheck' => 1}); + %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra); } else { %dumphash= &dump('nohist_userroles',$udom,$uname); @@ -3883,6 +3940,44 @@ sub coursedescription { return %returnhash; } +sub update_released_required { + my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_; + if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') { + $cid = $env{'request.course.id'}; + $cdom = $env{'course.'.$cid.'.domain'}; + $cnum = $env{'course.'.$cid.'.num'}; + $chome = $env{'course.'.$cid.'.home'}; + } + if ($needsrelease) { + my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired'); + my $needsupdate; + if ($curr_reqd_hash{'internal.releaserequired'} eq '') { + $needsupdate = 1; + } else { + my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); + my ($needsmajor,$needsminor) = split(/\./,$needsrelease); + if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) { + $needsupdate = 1; + } + } + if ($needsupdate) { + my %needshash = ( + 'internal.releaserequired' => $needsrelease, + ); + my $putresult = &put('environment',\%needshash,$cdom,$cnum); + if ($putresult eq 'ok') { + &appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease}); + my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); + if (ref($crsinfo{$cid}) eq 'HASH') { + $crsinfo{$cid}{'releaserequired'} = $needsrelease; + &courseidput($cdom,\%crsinfo,$chome,'notime'); + } + } + } + } + return; +} + # -------------------------------------------------See if a user is privileged sub privileged { @@ -3922,9 +4017,10 @@ sub rolesinit { my ($domain,$username,$authhost)=@_; my $now=time; my %userroles = ('user.login.time' => $now); - my $rolesdump=reply("dump:$domain:$username:roles",$authhost); + my $extra = &freeze_escape({'skipcheck' => 1}); + my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost); if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || - ($rolesdump =~ /^error:/)) { + ($rolesdump =~ /^error:/)) { return \%userroles; } my %allroles=(); @@ -4272,7 +4368,7 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { - my ($namespace,$udomain,$uname,$regexp,$range)=@_; + my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -4281,7 +4377,7 @@ sub dump { } else { $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 %returnhash=(); foreach my $item (@pairs) { @@ -4826,7 +4922,7 @@ sub is_portfolio_file { } sub usertools_access { - my ($uname,$udom,$tool,$action,$context) = @_; + my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_; my ($access,%tools); if ($context eq '') { $context = 'tools'; @@ -4868,9 +4964,14 @@ sub usertools_access { $toolstatus = $env{'environment.'.$context.'.'.$tool}; $inststatus = $env{'environment.inststatus'}; } else { - my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); - $toolstatus = $userenv{$context.'.'.$tool}; - $inststatus = $userenv{'inststatus'}; + if (ref($userenvref) eq 'HASH') { + $toolstatus = $userenvref->{$context.'.'.$tool}; + $inststatus = $userenvref->{'inststatus'}; + } else { + my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); + $toolstatus = $userenv{$context.'.'.$tool}; + $inststatus = $userenv{'inststatus'}; + } } if ($toolstatus ne '') { @@ -4882,8 +4983,17 @@ sub usertools_access { return $access; } - my $is_adv = &is_advanced_user($udom,$uname); - my %domdef = &get_domain_defaults($udom); + my ($is_adv,%domdef); + 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 ($is_adv) { if ($domdef{$tool}{'_LC_adv'} ne '') { @@ -4957,6 +5067,11 @@ sub is_course_owner { sub is_advanced_user { 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 %allroles; my $is_adv; @@ -5679,8 +5794,7 @@ sub update_allusers_table { 'generation='.&escape($names->{'generation'}).'%%'. 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. 'id='.&escape($names->{'id'}),$homeserver); - my $reply = &get_query_reply($queryid); - return $reply; + return; } # ------- Request retrieval of institutional classlists for course(s) @@ -6243,7 +6357,8 @@ sub get_users_groups { } else { $grouplist = ''; 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. '.default_enrollment_end_date'}; my $now = time; @@ -6603,6 +6718,10 @@ sub modifyuser { ' by '.$env{'user.name'}.' at '.$env{'user.domain'}. ' in domain '.$env{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); + my $newuser; + if ($uhome eq 'no_host') { + $newuser = 1; + } # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && (($umode && $upass) || ($umode eq 'localauth'))) { @@ -6655,11 +6774,12 @@ sub modifyuser { ['firstname','middlename','lastname','generation','id', 'permanentemail','inststatus'], $udom,$uname); - my %names; + my (%names,%oldnames); if ($tmp[0] =~ m/^error:.*/) { %names=(); } else { %names = @tmp; + %oldnames = %names; } # # If name, email and/or uid are blank (e.g., because an uploaded file @@ -6713,18 +6833,37 @@ sub modifyuser { } } } - my $reply = &put('environment', \%names, $udom,$uname); - if ($reply ne 'ok') { return 'error: '.$reply; } - my $sqlresult = &update_allusers_table($uname,$udom,\%names); - &devalidate_cache_new('namescache',$uname.':'.$udom); - my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '. + my $logmsg = $udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. - $last.', '.$gene.', '.$email.', '.$inststatus; + $last.', '.$gene.', '.$email.', '.$inststatus; if ($env{'user.name'} ne '' && $env{'user.domain'}) { $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; } else { $logmsg .= ' during self creation'; } + my $changed; + if ($newuser) { + $changed = 1; + } else { + foreach my $field (@fields) { + if ($names{$field} ne $oldnames{$field}) { + $changed = 1; + last; + } + } + } + unless ($changed) { + $logmsg = 'No changes in user information needed for: '.$logmsg; + &logthis($logmsg); + return 'ok'; + } + my $reply = &put('environment', \%names, $udom,$uname); + if ($reply ne 'ok') { + return 'error: '.$reply; + } + my $sqlresult = &update_allusers_table($uname,$udom,\%names); + &devalidate_cache_new('namescache',$uname.':'.$udom); + $logmsg = 'Success modifying user '.$logmsg; &logthis($logmsg); return 'ok'; } @@ -10094,6 +10233,10 @@ sub get_dns { } +sub all_loncaparevs { + return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10); +} + BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf @@ -10197,8 +10340,23 @@ BEGIN { } } -sub all_loncaparevs { - return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10); +{ + my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; + if (-e $file) { + my $parser = HTML::LCParser->new($file); + while (my $token = $parser->get_token()) { + if ($token->[0] eq 'S') { + my $item = $token->[1]; + my $name = $token->[2]{'name'}; + my $value = $token->[2]{'value'}; + if ($item ne '' && $name ne '' && $value ne '') { + my $release = $parser->get_text(); + $release =~ s/(^\s*|\s*$ )//gx; + $needsrelease{$item.':'.$name.':'.$value} = $release; + } + } + } + } } # ------------- set up temporary directory