[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.908 and 1.914

version 1.908, 2007/08/29 22:19:24 version 1.914, 2007/09/29 04:03:51
Line 582  sub compare_server_load { Line 582  sub compare_server_load {
     }      }
     return ($spare_server,$lowest_load);      return ($spare_server,$lowest_load);
 }  }
   
   # --------------------------- ask offload servers if user already has a session
   sub find_existing_session {
       my ($udom,$uname) = @_;
       foreach my $try_server (@{ $spareid{'primary'} },
       @{ $spareid{'default'} }) {
    return $try_server if (&has_user_session($try_server, $udom, $uname));
       }
       return;
   }
   
   # -------------------------------- ask if server already has a session for user
   sub has_user_session {
       my ($lonid,$udom,$uname) = @_;
       my $result = &reply(join(':','userhassession',
        map {&escape($_)} ($udom,$uname)),$lonid);
       return 1 if ($result eq 'ok');
   
       return 0;
   }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 861  sub inst_directory_query { Line 882  sub inst_directory_query {
     my $udom = $srch->{'srchdomain'};      my $udom = $srch->{'srchdomain'};
     my %results;      my %results;
     my $homeserver = &domain($udom,'primary');      my $homeserver = &domain($udom,'primary');
       my $outcome;
     if ($homeserver ne '') {      if ($homeserver ne '') {
  my $queryid=&reply("querysend:instdirsearch:".   my $queryid=&reply("querysend:instdirsearch:".
    &escape($srch->{'srchby'}).':'.     &escape($srch->{'srchby'}).':'.
Line 880  sub inst_directory_query { Line 902  sub inst_directory_query {
  }   }
   
         if (!&error($response) && $response ne 'refused') {          if (!&error($response) && $response ne 'refused') {
             my @matches = split(/\n/,$response);              if ($response eq 'unavailable') {
             foreach my $match (@matches) {                  $outcome = $response;
                 my ($key,$value) = split(/=/,$match);              } else {
                 $results{&unescape($key).':'.$udom} = &thaw_unescape($value);                  $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key).':'.$udom} = &thaw_unescape($value);
                   }
             }              }
         }          }
     }      }
     return %results;      return ($outcome,%results);
 }  }
   
 sub usersearch {  sub usersearch {
Line 900  sub usersearch { Line 927  sub usersearch {
         if (&host_domain($tryserver) eq $dom) {          if (&host_domain($tryserver) eq $dom) {
             my $host=&hostname($tryserver);              my $host=&hostname($tryserver);
             my $queryid=              my $queryid=
                 &reply("querysend:".&escape($query).':'.&escape($dom).':'.                  &reply("querysend:".&escape($query).':'.
                        &escape($srch->{'srchby'}).'%%'.                         &escape($srch->{'srchby'}).':'.
                        &escape($srch->{'srchtype'}).':'.                         &escape($srch->{'srchtype'}).':'.
                        &escape($srch->{'srchterm'}),$tryserver);                         &escape($srch->{'srchterm'}),$tryserver);
             if ($queryid !~/^\Q$host\E\_/) {              if ($queryid !~/^\Q$host\E\_/) {
Line 918  sub usersearch { Line 945  sub usersearch {
             if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {              if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
                 &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);                  &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);
             } else {              } else {
                 my @matches = split(/&/,$reply);                  my @matches;
                   if ($reply =~ /\n/) {
                       @matches = split(/\n/,$reply);
                   } else {
                       @matches = split(/\&/,$reply);
                   }
                 foreach my $match (@matches) {                  foreach my $match (@matches) {
                     my @items = split(/:/,$match);  
                     my ($uname,$udom,%userhash);                      my ($uname,$udom,%userhash);
                     foreach my $entry (@items) {                      foreach my $entry (split(/:/,$match)) {
                         my ($key,$value) = split(/=/,$entry);                          my ($key,$value) =
                         $key = &unescape($key);                              map {&unescape($_);} split(/=/,$entry);
                         $value = &unescape($value);  
                         $userhash{$key} = $value;                          $userhash{$key} = $value;
                         if ($key eq 'username') {                          if ($key eq 'username') {
                             $uname = $value;                              $uname = $value;
                         } elsif ($key eq 'domain') {                          } elsif ($key eq 'domain') {
                             $udom = $value;                              $udom = $value;
                         }                           }
                     }                      }
                     $results{$uname.':'.$udom} = \%userhash;                      $results{$uname.':'.$udom} = \%userhash;
                 }                  }
Line 941  sub usersearch { Line 971  sub usersearch {
     return %results;      return %results;
 }  }
   
   sub get_instuser {
       my ($udom,$uname,$id) = @_;
       my $homeserver = &domain($udom,'primary');
       my ($outcome,%results);
       if ($homeserver ne '') {
           my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
                              &escape($id).':'.&escape($udom),$homeserver);
           my $host=&hostname($homeserver);
           if ($queryid !~/^\Q$host\E\_/) {
               &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
               return;
           }
           my $response = &get_query_reply($queryid);
           my $maxtries = 5;
           my $tries = 1;
           while (($response=~/^timeout/) && ($tries < $maxtries)) {
               $response = &get_query_reply($queryid);
               $tries ++;
           }
           if (!&error($response) && $response ne 'refused') {
               if ($response eq 'unavailable') {
                   $outcome = $response;
               } else {
                   $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       my %userinfo;
       if (ref($results{$uname}) eq 'HASH') {
           %userinfo = %{$results{$uname}};
       } 
       return ($outcome,%userinfo);
   }
   
   sub inst_rulecheck {
       my ($udom,$uname,$rules) = @_;
       my %returnhash;
       if ($udom ne '') {
           if (ref($rules) eq 'ARRAY') {
               @{$rules} = map {&escape($_);} (@{$rules});
               my $rulestr = join(':',@{$rules});
               my $homeserver=&domain($udom,'primary');
               if (($homeserver ne '') && ($homeserver ne 'no_host')) {
                   my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'.
                                                 &escape($uname).':'.$rulestr,
                                                 $homeserver));
                   if ($response ne 'refused') {
                       my @pairs=split(/\&/,$response);
                       foreach my $item (@pairs) {
                           my ($key,$value)=split(/=/,$item,2);
                           $key = &unescape($key);
                           next if ($key =~ /^error: 2 /);
                           $returnhash{$key}=&thaw_unescape($value);
                       }
                   }
               }
           }
       }
       return %returnhash;
   }
   
   sub inst_userrules {
       my ($udom) = @_;
       my (%ruleshash,@ruleorder);
       if ($udom ne '') {
           my $homeserver=&domain($udom,'primary');
           if (($homeserver ne '') && ($homeserver ne 'no_host')) {
               my $response=&reply('instuserrules:'.&escape($udom),
                                    $homeserver);
               if (($response ne 'refused') && ($response ne 'error') && 
                   ($response ne 'no_such_host')) {
                   my ($hashitems,$orderitems) = split(/:/,$response);
                   my @pairs=split(/\&/,$hashitems);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/=/,$item,2);
                       $key = &unescape($key);
                       next if ($key =~ /^error: 2 /);
                       $ruleshash{$key}=&thaw_unescape($value);
                   }
                   my @esc_order = split(/\&/,$orderitems);
                   foreach my $item (@esc_order) {
                       push(@ruleorder,&unescape($item));
                   }
               }
           }
       }
       return (\%ruleshash,\@ruleorder);
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 1217  sub do_cache_new { Line 1341  sub do_cache_new {
  $time=600;   $time=600;
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     if (!($memcache->set($id,$setvalue,$time))) {      my $result = $memcache->set($id,$setvalue,$time);
       if (! $result) {
  &logthis("caching of id -> $id  failed");   &logthis("caching of id -> $id  failed");
    $memcache->disconnect_all();
     }      }
     # need to make a copy of $value      # need to make a copy of $value
     #&make_room($id,$value,$debug);      #&make_room($id,$value,$debug);
Line 7727  sub hreflocation { Line 7853  sub hreflocation {
  $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/   $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
     -/uploaded/$1/$2/-x;      -/uploaded/$1/$2/-x;
     }      }
       if ($file=~ m{^/userfiles/}) {
    $file =~ s{^/userfiles/}{/uploaded/};
       }
     return $file;      return $file;
 }  }
   
Removed from v.1.908  
changed lines
  Added in v.1.914

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