[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.662 and 1.670

version 1.662, 2005/10/11 21:29:38 version 1.670, 2005/10/28 21:51:50
Line 443  sub overloaderror { Line 443  sub overloaderror {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent) = @_;      my ($loadpercent,$userloadpercent,$want_server_name) = @_;
     my $tryserver;      my $tryserver;
     my $spareserver='';      my $spareserver='';
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowestserver=$loadpercent > $userloadpercent?
              $loadpercent :  $userloadpercent;               $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys(%spareid)) {
  my $loadans=reply('load',$tryserver);   my $loadans=&reply('load',$tryserver);
  my $userloadans=reply('userload',$tryserver);   my $userloadans=&reply('userload',$tryserver);
  if ($loadans !~ /\d/ && $userloadans !~ /\d/) {   if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
     next; #didn't get a number from the server      next; #didn't get a number from the server
  }   }
Line 468  sub spareserver { Line 468  sub spareserver {
     $answer = $userloadans;      $answer = $userloadans;
  }   }
  if (($answer =~ /\d/) && ($answer<$lowestserver)) {   if (($answer =~ /\d/) && ($answer<$lowestserver)) {
     $spareserver="http://$hostname{$tryserver}";      if ($want_server_name) {
    $spareserver=$tryserver;
       } else {
    $spareserver="http://$hostname{$tryserver}";
       }
     $lowestserver=$answer;      $lowestserver=$answer;
  }   }
     }      }
Line 1176  sub process_coursefile { Line 1180  sub process_coursefile {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,          $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
      $home);       $home);
     } else {      } else {
         my $fetchresult = '';  
         my $fpath = '';          my $fpath = '';
         my $fname = $file;          my $fname = $file;
         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);          ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
Line 1862  sub dcmaildump { Line 1865  sub dcmaildump {
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if ($hostdom{$tryserver} eq $dom) {          if ($hostdom{$tryserver} eq $dom) {
             %{$returnhash{$tryserver}}=();              %{$returnhash{$tryserver}}=();
             foreach (      my $cmd='dcmaildump:'.$dom.':'.
                 split(/\&/,&reply('dcmaildump:'.$dom.':'.   &escape($startdate).':'.&escape($enddate).':';
                    &escape($startdate).':'.&escape($enddate).':'.      my @esc_senders=map { &escape($_)} @$senders;
                    &escape($senders), $tryserver))) {      $cmd.=&escape(join('&',@esc_senders));
       foreach (split(/\&/,&reply($cmd,$tryserver))) {
                 my ($key,$value) = split(/\=/,$_);                  my ($key,$value) = split(/\=/,$_);
                 if (($key) && ($value)) {                  if (($key) && ($value)) {
                     $returnhash{$tryserver}{&unescape($key)} = &unescape($value);                      $returnhash{$tryserver}{&unescape($key)} = &unescape($value);
Line 2954  sub eget { Line 2958  sub eget {
    return %returnhash;     return %returnhash;
 }  }
   
   # ------------------------------------------------------------ tmpput interface
   sub tmpput {
       my ($storehash,$server)=@_;
       my $items='';
       foreach (keys(%$storehash)) {
    $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
       }
       $items=~s/\&$//;
       return &reply("tmpput:$items",$server);
   }
   
   # ------------------------------------------------------------ tmpget interface
   sub tmpget {
       my ($token)=@_;
       my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});
       my %returnhash;
       foreach my $item (split(/\&/,$rep)) {
    my ($key,$value)=split(/=/,$item);
    $returnhash{&unescape($key)}=&thaw_unescape($value);
       }
       return %returnhash;
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 3075  sub allowed { Line 3102  sub allowed {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
 # URI is an uploaded document for this course  # URI is an uploaded document for this course, default permissions don't matter
 # not allowing 'edit' access (editupload) to uploaded course docs  # not allowing 'edit' access (editupload) to uploaded course docs
     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {      if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
    $thisallowed='';
  my $refuri=$env{'httpref.'.$orguri};   my $refuri=$env{'httpref.'.$orguri};
  if ($refuri) {   if ($refuri) {
     if ($refuri =~ m|^/adm/|) {      if ($refuri =~ m|^/adm/|) {
  $thisallowed='F';   $thisallowed='F';
       } else {
                   $refuri=&declutter($refuri);
                   my ($match) = &is_on_map($refuri);
                   if ($match) {
                       $thisallowed='F';
                   }
     }      }
    } else {
       $thisallowed='';
  }   }
     }      }
   
Line 3669  sub assignrole { Line 3705  sub assignrole {
     my $answer=&reply($command,&homeserver($uname,$udom));      my $answer=&reply($command,&homeserver($uname,$udom));
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($mrole,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
     }      }
     return $answer;      return $answer;
 }  }
Line 5785  sub filelocation { Line 5821  sub filelocation {
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {      unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
  my $finalpath=filelocation($dir,$file);   $file=filelocation($dir,$file);
  $finalpath=~s-^/home/httpd/html--;      }
  $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  return $finalpath;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
     } elsif ($file=~m-^/home-) {      } elsif ($file=~m-/home/(\w+)/public_html/-) {
  $file=~s-^/home/httpd/html--;  
  $file=~s-^/home/(\w+)/public_html/-/~$1/-;   $file=~s-^/home/(\w+)/public_html/-/~$1/-;
  return $file;      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
    $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
       -/uploaded/$1/$2/-x;
     }      }
     return $file;      return $file;
 }  }
Removed from v.1.662  
changed lines
  Added in v.1.670

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