[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1056.4.11 and 1.1063

version 1.1056.4.11, 2010/10/01 14:26:07 version 1.1063, 2010/05/20 18:11:18
Line 76  use HTTP::Date; Line 76  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease);              $_64bit %env %protocol);
   
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 196  sub get_server_timezone { Line 196  sub get_server_timezone {
 }  }
   
 sub get_server_loncaparev {  sub get_server_loncaparev {
     my ($dom,$lonhost,$ignore_cache,$caller) = @_;      my ($dom,$lonhost) = @_;
     if (defined($lonhost)) {      if (defined($lonhost)) {
         if (!defined(&hostname($lonhost))) {          if (!defined(&hostname($lonhost))) {
             undef($lonhost);              undef($lonhost);
Line 211  sub get_server_loncaparev { Line 211  sub get_server_loncaparev {
         }          }
     }      }
     if (defined($lonhost)) {      if (defined($lonhost)) {
         my $cachetime = 12*3600;          my $cachetime = 24*3600;
         if (!$ignore_cache) {          my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
             my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);  
             if (defined($cached)) {  
                 return $loncaparev;  
             }  
         }  
         my ($answer,$loncaparev);  
         my @ids=&current_machine_ids();  
         if (grep(/^\Q$lonhost\E$/,@ids)) {  
             $answer = $perlvar{'lonVersion'};  
             if ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {  
                 $loncaparev = $1;  
             }  
         } else {  
             $answer = &reply('serverloncaparev',$lonhost);  
             if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {  
                 if ($caller eq 'loncron') {  
                     my $ua=new LWP::UserAgent;  
                     $ua->timeout(4);  
                     my $protocol = $protocol{$lonhost};  
                     $protocol = 'http' if ($protocol ne 'https');  
                     my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';  
                     my $request=new HTTP::Request('GET',$url);  
                     my $response=$ua->request($request);  
                     unless ($response->is_error()) {  
                         my $content = $response->content;  
                         if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {  
                             $loncaparev = $1;  
                         }  
                     }  
                 } else {  
                     $loncaparev = $loncaparevs{$lonhost};  
                 }  
             } elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {  
                 $loncaparev = $1;  
             }  
         }  
         return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);  
     }  
 }  
   
 sub get_server_homeID {  
     my ($hostname,$ignore_cache,$caller) = @_;  
     unless ($ignore_cache) {  
         my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname);  
         if (defined($cached)) {          if (defined($cached)) {
             return $serverhomeID;              return $loncaparev;
         }          } else {
     }              my $loncaparev = &reply('serverloncaparev',$lonhost);
     my $cachetime = 12*3600;              return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
     my $serverhomeID;  
     if ($caller eq 'loncron') {  
         my @machine_ids = &machine_ids($hostname);  
         foreach my $id (@machine_ids) {  
             my $response = &reply('serverhomeID',$id);  
             unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) {  
                 $serverhomeID = $response;  
                 last;  
             }  
         }  
         if ($serverhomeID eq '') {  
             $serverhomeID = $machine_ids[-1];  
         }          }
     } else {  
         $serverhomeID = $serverhomeIDs{$hostname};  
     }      }
     return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);  
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
Line 724  sub userload { Line 665  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
 # ------------------------------------------ Fight off request when overloaded  
   
 sub overloaderror {  
     my ($r,$checkserver)=@_;  
     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }  
     my $loadavg;  
     if ($checkserver eq $perlvar{'lonHostID'}) {  
        open(my $loadfile,'/proc/loadavg');  
        $loadavg=<$loadfile>;  
        $loadavg =~ s/\s.*//g;  
        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};  
        close($loadfile);  
     } else {  
        $loadavg=&reply('load',$checkserver);  
     }  
     my $overload=$loadavg-100;  
     if ($overload>0) {  
  $r->err_headers_out->{'Retry-After'}=$overload;  
         $r->log_error('Overload of '.$overload.' on '.$checkserver);  
         return 413;  
     }      
     return '';  
 }  
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
Line 756  sub spareserver { Line 673  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 776  sub spareserver { Line 683  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 792  sub spareserver { Line 695  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 807  sub compare_server_load { Line 710  sub compare_server_load {
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
   
     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
         return; #didn't get a number from the server   next; #didn't get a number from the server
     }      }
   
     my $load;      my $load;
Line 850  sub has_user_session { Line 753  sub has_user_session {
     return 0;      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  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 929  sub queryauthenticate { Line 811  sub queryauthenticate {
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
   
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_;      my ($uname,$upass,$udom,$checkdefauth)=@_;
     $upass=&escape($upass);      $upass=&escape($upass);
     $uname= &LONCAPA::clean_username($uname);      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom,1);      my $uhome=&homeserver($uname,$udom,1);
Line 952  sub authenticate { Line 834  sub authenticate {
     return 'no_host';      return 'no_host';
         }          }
     }      }
     my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome);      my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
     if ($answer eq 'authorized') {      if ($answer eq 'authorized') {
         if ($newhome) {          if ($newhome) {
             &logthis("User $uname at $udom authorized by $uhome, but needs account");              &logthis("User $uname at $udom authorized by $uhome, but needs account");
Line 970  sub authenticate { Line 852  sub authenticate {
     return 'no_host';      return 'no_host';
 }  }
   
 sub can_host_session {  
     my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;  
     my $canhost = 1;  
     my $host_idn = &Apache::lonnet::internet_dom($lonhost);  
     if (ref($remotesessions) eq 'HASH') {  
         if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {  
             if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {  
                 $canhost = 0;  
             } else {  
                 $canhost = 1;  
             }  
         }  
         if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') {  
             if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) {  
                 $canhost = 1;  
             } else {  
                 $canhost = 0;  
             }  
         }  
         if ($canhost) {  
             if ($remotesessions->{'version'} ne '') {  
                 my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/);  
                 if ($reqmajor ne '' && $reqminor ne '') {  
                     if ($remoterev =~ /^\'?(\d+)\.(\d+)/) {  
                         my $major = $1;  
                         my $minor = $2;  
                         if (($major < $reqmajor ) ||  
                             (($major == $reqmajor) && ($minor < $reqminor))) {  
                             $canhost = 0;  
                         }  
                     } else {  
                         $canhost = 0;  
                     }  
                 }  
             }  
         }  
     }  
     if ($canhost) {  
         if (ref($hostedsessions) eq 'HASH') {  
             if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {  
                 if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {  
                     $canhost = 0;  
                 } else {  
                     $canhost = 1;  
                 }  
             }  
             if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {  
                 if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {  
                     $canhost = 1;  
                 } else {  
                     $canhost = 0;  
                 }  
             }  
         }  
     }  
     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 1524  sub get_domain_defaults { Line 1328  sub get_domain_defaults {
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions'],$domain);                                    'coursedefaults'],$domain);
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 1564  sub get_domain_defaults { Line 1368  sub get_domain_defaults {
             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};              $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {  
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {  
             $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'};  
         }  
         if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {  
             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};  
         }  
     }  
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                   $cachetime);                                    $cachetime);
     return %domdefaults;      return %domdefaults;
Line 1757  sub getsection { Line 1553  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 $extra = &freeze_escape({'skipcheck' => 1});      my %roleshash = &dump('roles',$udom,$unam,$courseid);
     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 3061  sub get_my_roles { Line 2856  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') { 
         my $extra = &freeze_escape({'skipcheck' => 1});          %dumphash = &dump('roles',$udom,$uname);
         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);  
     } else {      } else {
         %dumphash=          %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
Line 3241  sub courseiddump { Line 3035  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;          $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 3263  sub courseiddump { Line 3057  sub courseiddump {
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.                           $showhidden.':'.$caller.':'.&escape($cloner).':'.
                          &escape($cc_clone).':'.$cloneonly.':'.                           &escape($cc_clone).':'.$cloneonly.':'.
                          &escape($createdbefore).':'.&escape($createdafter).':'.                           &escape($createdbefore).':'.&escape($createdafter).':'.
                          &escape($creationcontext).':'.$domcloner,                           &escape($creationcontext),$tryserver);
                          $tryserver);  
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 3390  sub get_domain_roles { Line 3183  sub get_domain_roles {
     return %personnel;      return %personnel;
 }  }
   
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Interval timing 
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb)=@_;
Line 3426  sub set_first_access { Line 3219  sub set_first_access {
     return 'already_set';      return 'already_set';
 }  }
   
 sub checkout {  
     my ($symb,$tuname,$tudom,$tcrsid)=@_;  
     my $now=time;  
     my $lonhost=$perlvar{'lonHostID'};  
     my $infostr=&escape(  
                  'CHECKOUTTOKEN&'.  
                  $tuname.'&'.  
                  $tudom.'&'.  
                  $tcrsid.'&'.  
                  $symb.'&'.  
  $now.'&'.$ENV{'REMOTE_ADDR'});  
     my $token=&reply('tmpput:'.$infostr,$lonhost);  
     if ($token=~/^error\:/) {   
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
         return '';   
     }  
   
     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;  
     $token=~tr/a-z/A-Z/;  
   
     my %infohash=('resource.0.outtoken' => $token,  
                   'resource.0.checkouttime' => $now,  
                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }      
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkout '.$infostr.' - '.  
                                                  $token)) ne 'ok') {  
  return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }  
     return $token;  
 }  
   
 # ------------------------------------------------------------ Check in an item  
   
 sub checkin {  
     my $token=shift;  
     my $now=time;  
     my ($ta,$tb,$lonhost)=split(/\*/,$token);  
     $lonhost=~tr/A-Z/a-z/;  
     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;  
     $dtoken=~s/\W/\_/g;  
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=  
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));  
   
     unless (($tuname) && ($tudom)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') failed');  
         return '';  
     }  
       
     unless (&allowed('mgr',$tcrsid)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.  
                  $env{'user.name'}.' - '.$env{'user.domain'});  
         return '';  
     }  
   
     my %infohash=('resource.0.intoken' => $token,  
                   'resource.0.checkintime' => $now,  
                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     }      
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkin - '.$token)) ne 'ok') {  
  return '';  
     }  
   
     return ($symb,$tuname,$tudom,$tcrsid);      
 }  
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 4049  sub coursedescription { Line 3757  sub coursedescription {
     return %returnhash;      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  # -------------------------------------------------See if a user is privileged
   
 sub privileged {  sub privileged {
Line 4126  sub rolesinit { Line 3796  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({'skipcheck' => 1});      my $rolesdump=reply("dump:$domain:$username:roles",$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:/)) { 
         return \%userroles;          return \%userroles;
     }      }
     my %allroles=();      my %allroles=();
Line 4250  sub standard_roleprivs { Line 3919  sub standard_roleprivs {
 }  }
   
 sub set_userprivs {  sub set_userprivs {
     my ($userroles,$allroles,$allgroups,$groups_roles) = @_;       my ($userroles,$allroles,$allgroups) = @_; 
     my $author=0;      my $author=0;
     my $adv=0;      my $adv=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         my @groupkeys;  
         foreach my $role (keys(%{$allroles})) {          foreach my $role (keys(%{$allroles})) {
             push(@groupkeys,$role);              my ($trole,$area,$sec,$extendedarea);
         }              if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
         if (ref($groups_roles) eq 'HASH') {                  $trole = $1;
             foreach my $key (keys(%{$groups_roles})) {                  $area = $2;
                 unless (grep(/^\Q$key\E$/,@groupkeys)) {                  $sec = $3;
                     push(@groupkeys,$key);                  $extendedarea = $area.$sec;
                 }                  if (exists($$allgroups{$area})) {
             }                      foreach my $group (keys(%{$$allgroups{$area}})) {
         }                          my $spec = $trole.'.'.$extendedarea;
         if (@groupkeys > 0) {                          $grouproles{$spec.'.'.$area.'/'.$group} = 
             foreach my $role (@groupkeys) {  
                 my ($trole,$area,$sec,$extendedarea);  
                 if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {  
                     $trole = $1;  
                     $area = $2;  
                     $sec = $3;  
                     $extendedarea = $area.$sec;  
                     if (exists($$allgroups{$area})) {  
                         foreach my $group (keys(%{$$allgroups{$area}})) {  
                             my $spec = $trole.'.'.$extendedarea;  
                             $grouproles{$spec.'.'.$area.'/'.$group} =   
                                                 $$allgroups{$area}{$group};                                                  $$allgroups{$area}{$group};
                         }  
                     }                      }
                 }                  }
             }              }
Line 4326  sub role_status { Line 3982  sub role_status {
                 if ($$tstart<$now) {                  if ($$tstart<$now) {
                     if ($$tstart && $$tstart>$refresh) {                      if ($$tstart && $$tstart>$refresh) {
                         if (($$where ne '') && ($$role ne '')) {                          if (($$where ne '') && ($$role ne '')) {
                             my (%allroles,%allgroups,$group_privs,                              my (%allroles,%allgroups,$group_privs);
                                 %groups_roles,@rolecodes);  
                             my %userroles = (                              my %userroles = (
                                 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend                                  'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                             );                              );
                             @rolecodes = ('cm');  
                             my $spec=$$role.'.'.$$where;                              my $spec=$$role.'.'.$$where;
                             my ($tdummy,$tdomain,$trest)=split(/\//,$$where);                              my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                             if ($$role =~ /^cr\//) {                              if ($$role =~ /^cr\//) {
                                 &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);                                  &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
                                 push(@rolecodes,'cr');  
                             } elsif ($$role eq 'gr') {                              } elsif ($$role eq 'gr') {
                                 push(@rolecodes,$$role);  
                                 my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},                                  my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
                                                     $env{'user.name'});                                                      $env{'user.name'});
                                 my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);                                  my ($trole) = split('_',$rolehash{$$where.'_'.$$role},1);
                                 (undef,my $group_privs) = split(/\//,$trole);                                  (undef,my $group_privs) = split(/\//,$trole);
                                 $group_privs = &unescape($group_privs);                                  $group_privs = &unescape($group_privs);
                                 &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);                                  &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
                                 my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);  
                                 if (keys(%course_roles) > 0) {  
                                     my ($tnum) = ($trest =~ /^($match_courseid)/);  
                                     if ($tdomain ne '' && $tnum ne '') {  
                                         foreach my $key (keys(%course_roles)) {  
                                             if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {  
                                                 my $crsrole = $1;  
                                                 my $crssec = $2;  
                                                 if ($crsrole =~ /^cr/) {  
                                                     unless (grep(/^cr$/,@rolecodes)) {  
                                                         push(@rolecodes,'cr');  
                                                     }  
                                                 } else {  
                                                     unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {  
                                                         push(@rolecodes,$crsrole);  
                                                     }  
                                                 }  
                                                 my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;  
                                                 if ($crssec ne '') {  
                                                     $rolekey .= '/'.$crssec;  
                                                 }  
                                                 $rolekey .= './';  
                                                 $groups_roles{$rolekey} = \@rolecodes;  
                                             }  
                                         }  
                                     }  
                                 }  
                             } else {                              } else {
                                 push(@rolecodes,$$role);  
                                 &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);                                  &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
                             }                              }
                             my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);                              my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
                             &appenv(\%userroles,\@rolecodes);                              &appenv(\%userroles,[$$role,'cm']);
                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);                              &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
                         }                          }
                     }                      }
Line 4477  sub del { Line 4101  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;      my ($namespace,$udomain,$uname,$regexp,$range)=@_;
     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 4486  sub dump { Line 4110  sub dump {
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     foreach my $item (@pairs) {      foreach my $item (@pairs) {
Line 5031  sub is_portfolio_file { Line 4655  sub is_portfolio_file {
 }  }
   
 sub usertools_access {  sub usertools_access {
     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_;      my ($uname,$udom,$tool,$action,$context) = @_;
     my ($access,%tools);      my ($access,%tools);
     if ($context eq '') {      if ($context eq '') {
         $context = 'tools';          $context = 'tools';
Line 5073  sub usertools_access { Line 4697  sub usertools_access {
         $toolstatus = $env{'environment.'.$context.'.'.$tool};          $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         if (ref($userenvref) eq 'HASH') {          my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
             $toolstatus = $userenvref->{$context.'.'.$tool};          $toolstatus = $userenv{$context.'.'.$tool};
             $inststatus = $userenvref->{'inststatus'};          $inststatus = $userenv{'inststatus'};
         } else {  
             my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');  
             $toolstatus = $userenv{$context.'.'.$tool};  
             $inststatus = $userenv{'inststatus'};  
         }  
     }      }
   
     if ($toolstatus ne '') {      if ($toolstatus ne '') {
Line 5092  sub usertools_access { Line 4711  sub usertools_access {
         return $access;          return $access;
     }      }
   
     my ($is_adv,%domdef);      my $is_adv = &is_advanced_user($udom,$uname);
     if (ref($is_advref) eq 'HASH') {      my %domdef = &get_domain_defaults($udom);
         $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 5176  sub is_course_owner { Line 4786  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 5847  sub metadata_query { Line 5452  sub metadata_query {
     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) {
   #SD remove this
   &logthis("Querying server:$server");
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
     my $reply=&reply("querysend:".&escape($query),$server);      my $reply=&reply("querysend:".&escape($query),$server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
Line 5903  sub update_allusers_table { Line 5510  sub update_allusers_table {
                'generation='.&escape($names->{'generation'}).'%%'.                 'generation='.&escape($names->{'generation'}).'%%'.
                'permanentemail='.&escape($names->{'permanentemail'}).'%%'.                 'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
                'id='.&escape($names->{'id'}),$homeserver);                 'id='.&escape($names->{'id'}),$homeserver);
     return;      my $reply = &get_query_reply($queryid);
       return $reply;
 }  }
   
 # ------- Request retrieval of institutional classlists for course(s)  # ------- Request retrieval of institutional classlists for course(s)
Line 6097  sub auto_validate_instcode { Line 5705  sub auto_validate_instcode {
             $homeserver = &domain($cdom,'primary');              $homeserver = &domain($cdom,'primary');
         }          }
     }      }
     $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.      my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                         &escape($instcode).':'.&escape($owner),$homeserver));                             &escape($instcode).':'.&escape($owner),$homeserver));
     my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);      my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
     return ($outcome,$description);      return ($outcome,$description);
 }  }
Line 6466  sub get_users_groups { Line 6074  sub get_users_groups {
     } else {        } else {  
         $grouplist = '';          $grouplist = '';
         my $courseurl = &courseid_to_courseurl($courseid);          my $courseurl = &courseid_to_courseurl($courseid);
         my $extra = &freeze_escape({'skipcheck' => 1});          my %roleshash = &dump('roles',$udom,$uname,$courseurl);
         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 6821  sub modifyuser { Line 6428  sub modifyuser {
     }      }
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
              $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.       $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$env{'request.role.domain'});               ' in domain '.$env{'request.role.domain'});
     my $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
     my $newuser;  
     if ($uhome eq 'no_host') {  
         $newuser = 1;  
     }  
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth'))) {
Line 6883  sub modifyuser { Line 6486  sub modifyuser {
    ['firstname','middlename','lastname','generation','id',     ['firstname','middlename','lastname','generation','id',
                     'permanentemail','inststatus'],                      'permanentemail','inststatus'],
    $udom,$uname);     $udom,$uname);
     my (%names,%oldnames);      my %names;
     if ($tmp[0] =~ m/^error:.*/) {       if ($tmp[0] =~ m/^error:.*/) { 
         %names=();           %names=(); 
     } else {      } else {
         %names = @tmp;          %names = @tmp;
         %oldnames = %names;  
     }      }
 #  #
 # If name, email and/or uid are blank (e.g., because an uploaded file  # If name, email and/or uid are blank (e.g., because an uploaded file
Line 6942  sub modifyuser { Line 6544  sub modifyuser {
             }              }
         }          }
     }      }
     my $logmsg = $udom.', '.$uname.', '.$uid.', '.      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.', '.
                  $umode.', '.$first.', '.$middle.', '.                   $umode.', '.$first.', '.$middle.', '.
                  $last.', '.$gene.', '.$email.', '.$inststatus;           $last.', '.$gene.', '.$email.', '.$inststatus;
     if ($env{'user.name'} ne '' && $env{'user.domain'}) {      if ($env{'user.name'} ne '' && $env{'user.domain'}) {
         $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};          $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
     } else {      } else {
         $logmsg .= ' during self creation';          $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;  
     }  
     if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {  
         &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);  
     }  
     my $sqlresult = &update_allusers_table($uname,$udom,\%names);  
     &devalidate_cache_new('namescache',$uname.':'.$udom);  
     $logmsg = 'Success modifying user '.$logmsg;  
     &logthis($logmsg);      &logthis($logmsg);
     return 'ok';      return 'ok';
 }  }
Line 8647  sub metadata { Line 8227  sub metadata {
     }      }
  }   }
     } else {       } else { 
   
  if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
     $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
  }   }
Line 9996  sub get_dns { Line 9577  sub get_dns {
     my %libserv;      my %libserv;
     my $loaded;      my $loaded;
     my %name_to_host;      my %name_to_host;
     my %internetdom;  
   
     sub parse_hosts_tab {      sub parse_hosts_tab {
  my ($file) = @_;   my ($file) = @_;
Line 10004  sub get_dns { Line 9584  sub get_dns {
     next if ($configline =~ /^(\#|\s*$ )/x);      next if ($configline =~ /^(\#|\s*$ )/x);
     next if ($configline =~ /^\^/);      next if ($configline =~ /^\^/);
     chomp($configline);      chomp($configline);
     my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      if ($id && $domain && $role && $name) {
  $hostname{$id}=$name;   $hostname{$id}=$name;
Line 10020  sub get_dns { Line 9600  sub get_dns {
                 } else {                  } else {
                     $protocol{$id} = 'http';                      $protocol{$id} = 'http';
                 }                  }
                 if (defined($intdom)) {  
                     $internetdom{$id} = $intdom;  
                 }  
     }      }
  }   }
     }      }
Line 10085  sub get_dns { Line 9662  sub get_dns {
     }      }
   
     sub unique_library {      sub unique_library {
         #2x reverse removes all hostnames that appear more than once   #2x reverse removes all hostnames that appear more than once
         my %unique = reverse &all_library();          my %unique = reverse &all_library();
         return reverse %unique;          return reverse %unique;
     }      }
Line 10115  sub get_dns { Line 9692  sub get_dns {
   
     sub get_unique_servers {      sub get_unique_servers {
         my %unique = reverse &get_servers(@_);          my %unique = reverse &get_servers(@_);
         return reverse %unique;   return reverse %unique;
     }      }
   
     sub host_domain {      sub host_domain {
Line 10132  sub get_dns { Line 9709  sub get_dns {
  my @uniq = grep(!$seen{$_}++, values(%hostdom));   my @uniq = grep(!$seen{$_}++, values(%hostdom));
  return @uniq;   return @uniq;
     }      }
   
     sub internet_dom {  
         &load_hosts_tab() if (!$loaded);  
   
         my ($lonid) = @_;  
         return $internetdom{$lonid};  
     }  
 }  }
   
 {   { 
Line 10256  sub get_dns { Line 9826  sub get_dns {
         return undef;          return undef;
     }      }
   
     sub get_internet_names {  
         my ($lonid) = @_;  
         return if ($lonid eq '');  
         my ($idnref,$cached)=  
             &Apache::lonnet::is_cached_new('internetnames',$lonid);  
         if ($cached) {  
             return $idnref;  
         }  
         my $ip = &get_host_ip($lonid);  
         my @hosts = &get_hosts_from_ip($ip);  
         my %iphost = &get_iphost();  
         my (@idns,%seen);  
         foreach my $id (@hosts) {  
             my $dom = &host_domain($id);  
             my $prim_id = &domain($dom,'primary');  
             my $prim_ip = &get_host_ip($prim_id);  
             next if ($seen{$prim_ip});  
             if (ref($iphost{$prim_ip}) eq 'ARRAY') {  
                 foreach my $id (@{$iphost{$prim_ip}}) {  
                     my $intdom = &internet_dom($id);  
                     unless (grep(/^\Q$intdom\E$/,@idns)) {  
                         push(@idns,$intdom);  
                     }  
                 }  
             }  
             $seen{$prim_ip} = 1;  
         }  
         return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);  
     }  
   
 }  
   
 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 {  BEGIN {
Line 10367  BEGIN { Line 9903  BEGIN {
     close($config);      close($config);
 }  }
   
 # ---------------------------------------------------------- Read loncaparev table  
 {  
     if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {  
         if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {  
             while (my $configline=<$config>) {  
                 chomp($configline);  
                 my ($hostid,$loncaparev)=split(/:/,$configline);  
                 $loncaparevs{$hostid}=$loncaparev;  
             }  
             close($config);  
         }  
     }  
 }  
   
 # ---------------------------------------------------------- Read serverhostID table  
 {  
     if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {  
         if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {  
             while (my $configline=<$config>) {  
                 chomp($configline);  
                 my ($name,$id)=split(/:/,$configline);  
                 $serverhomeIDs{$name}=$id;  
             }  
             close($config);  
         }  
     }  
 }  
   
 {  
     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  # ------------- set up temporary directory
 {  {
     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';      $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
Line 10644  authentication scheme Line 10133  authentication scheme
   
 =item *  =item *
 X<authenticate()>  X<authenticate()>
 B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to  B<authenticate($uname,$upass,$udom)>: try to
 authenticate user from domain's lib servers (first use the current  authenticate user from domain's lib servers (first use the current
 one). C<$upass> should be the users password.  one). C<$upass> should be the users password.
 $checkdefauth is optional (value is 1 if a check should be made to  
    authenticate user using default authentication method, and allow  
    account creation if username does not have account in the domain).  
 $clientcancheckhost is optional (value is 1 if checking whether the  
    server can host will occur on the client side in lonauth.pm).  
   
 =item *  =item *
 X<homeserver()>  X<homeserver()>
Removed from v.1.1056.4.11  
changed lines
  Added in v.1.1063

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