[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.669 and 1.677

version 1.669, 2005/10/27 19:47:39 version 1.677, 2005/11/15 18:39:16
Line 49  use Apache::Constants qw(:common :http); Line 49  use Apache::Constants qw(:common :http);
 use HTML::LCParser;  use HTML::LCParser;
 use HTML::Parser;  use HTML::Parser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::lonlocal;  
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
   use Digest::MD5;
   
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
   
Line 166  sub reply { Line 167  sub reply {
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=\"blue\">WARNING:".
                 " $cmd to $server returned $answer</font>");                  " $cmd to $server returned $answer</font>");
     }      }
     return $answer;      return $answer;
Line 190  sub reconlonc { Line 191  sub reconlonc {
             sleep 5;              sleep 5;
             if (-e "$peerfile") { return; }              if (-e "$peerfile") { return; }
             &logthis(              &logthis(
   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");    "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
         } else {          } else {
     &logthis(      &logthis(
                "<font color=blue>WARNING:".                 "<font color=\"blue\">WARNING:".
                " lonc at pid $loncpid not responding, giving up</font>");                 " lonc at pid $loncpid not responding, giving up</font>");
         }          }
     } else {      } else {
      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');       &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
     }      }
 }  }
   
Line 206  sub reconlonc { Line 207  sub reconlonc {
 sub critical {  sub critical {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless ($hostname{$server}) {      unless ($hostname{$server}) {
         &logthis("<font color=blue>WARNING:".          &logthis("<font color=\"blue\">WARNING:".
                " Critical message to unknown server ($server)</font>");                 " Critical message to unknown server ($server)</font>");
         return 'no_such_host';          return 'no_such_host';
     }      }
Line 240  sub critical { Line 241  sub critical {
             }              }
             chomp($wcmd);              chomp($wcmd);
             if ($wcmd eq $cmd) {              if ($wcmd eq $cmd) {
  &logthis("<font color=blue>WARNING: ".   &logthis("<font color=\"blue\">WARNING: ".
                          "Connection buffer $dfilename: $cmd</font>");                           "Connection buffer $dfilename: $cmd</font>");
                 &logperm("D:$server:$cmd");                  &logperm("D:$server:$cmd");
         return 'con_delayed';          return 'con_delayed';
             } else {              } else {
                 &logthis("<font color=red>CRITICAL:"                  &logthis("<font color=\"red\">CRITICAL:"
                         ." Critical connection failed: $server $cmd</font>");                          ." Critical connection failed: $server $cmd</font>");
                 &logperm("F:$server:$cmd");                  &logperm("F:$server:$cmd");
                 return 'con_failed';                  return 'con_failed';
Line 290  sub appenv { Line 291  sub appenv {
     my %newenv=@_;      my %newenv=@_;
     foreach (keys %newenv) {      foreach (keys %newenv) {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".              &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_}                  "Attempt to modify environment ".$_." to ".$newenv{$_}
                 .'</font>');                  .'</font>');
     delete($newenv{$_});      delete($newenv{$_});
Line 304  sub appenv { Line 305  sub appenv {
  return 'error: '.$!;   return 'error: '.$!;
     }      }
     unless (flock($lockfh,LOCK_EX)) {      unless (flock($lockfh,LOCK_EX)) {
          &logthis("<font color=blue>WARNING: ".           &logthis("<font color=\"blue\">WARNING: ".
                   'Could not obtain exclusive lock in appenv: '.$!);                    'Could not obtain exclusive lock in appenv: '.$!);
          close($lockfh);           close($lockfh);
          return 'error: '.$!;           return 'error: '.$!;
Line 349  sub delenv { Line 350  sub delenv {
     my $delthis=shift;      my $delthis=shift;
     my %newenv=();      my %newenv=();
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
Line 360  sub delenv { Line 361  sub delenv {
     return 'error';      return 'error';
  }   }
  unless (flock($fh,LOCK_SH)) {   unless (flock($fh,LOCK_SH)) {
     &logthis("<font color=blue>WARNING: ".      &logthis("<font color=\"blue\">WARNING: ".
      'Could not obtain shared lock in delenv: '.$!);       'Could not obtain shared lock in delenv: '.$!);
     close($fh);      close($fh);
     return 'error: '.$!;      return 'error: '.$!;
Line 374  sub delenv { Line 375  sub delenv {
     return 'error';      return 'error';
  }   }
  unless (flock($fh,LOCK_EX)) {   unless (flock($fh,LOCK_EX)) {
     &logthis("<font color=blue>WARNING: ".      &logthis("<font color=\"blue\">WARNING: ".
      'Could not obtain exclusive lock in delenv: '.$!);       'Could not obtain exclusive lock in delenv: '.$!);
     close($fh);      close($fh);
     return 'error: '.$!;      return 'error: '.$!;
Line 443  sub overloaderror { Line 444  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 469  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 1060  sub repcopy { Line 1065  sub repcopy {
            if ($response->is_error()) {             if ($response->is_error()) {
        unlink($transname);         unlink($transname);
                my $message=$response->status_line;                 my $message=$response->status_line;
                &logthis("<font color=blue>WARNING:"                 &logthis("<font color=\"blue\">WARNING:"
                        ." LWP get: $message: $filename</font>");                         ." LWP get: $message: $filename</font>");
                return 'unavailable';                 return 'unavailable';
            } else {             } else {
Line 1070  sub repcopy { Line 1075  sub repcopy {
                   if ($mresponse->is_error()) {                    if ($mresponse->is_error()) {
       unlink($filename.'.meta');        unlink($filename.'.meta');
                       &logthis(                        &logthis(
                      "<font color=yellow>INFO: No metadata: $filename</font>");                       "<font color=\"yellow\">INFO: No metadata: $filename</font>");
                   }                    }
        }         }
                rename($transname,$filename);                 rename($transname,$filename);
Line 1538  sub flushcourselogs { Line 1543  sub flushcourselogs {
         } else {          } else {
             &logthis('Failed to flush log buffer for '.$crsid);              &logthis('Failed to flush log buffer for '.$crsid);
             if (length($courselogs{$crsid})>40000) {              if (length($courselogs{$crsid})>40000) {
                &logthis("<font color=blue>WARNING: Buffer for ".$crsid.                 &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
                         " exceeded maximum size, deleting.</font>");                          " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
Line 1949  sub checkout { Line 1954  sub checkout {
  $now.'&'.$ENV{'REMOTE_ADDR'});   $now.'&'.$ENV{'REMOTE_ADDR'});
     my $token=&reply('tmpput:'.$infostr,$lonhost);      my $token=&reply('tmpput:'.$infostr,$lonhost);
     if ($token=~/^error\:/) {       if ($token=~/^error\:/) { 
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
         return '';           return ''; 
Line 1965  sub checkout { Line 1970  sub checkout {
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {      unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
        return '';         return '';
     } else {      } else {
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
     }          }    
Line 1975  sub checkout { Line 1980  sub checkout {
                                                  $token)) ne 'ok') {                                                   $token)) ne 'ok') {
  return '';   return '';
     } else {      } else {
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
     }      }
Line 3102  sub allowed { Line 3107  sub allowed {
 # 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='';   $thisallowed='';
  my $refuri=$env{'httpref.'.$orguri};          my ($match)=&is_on_map($uri);
  if ($refuri) {          if ($match) {
     if ($refuri =~ m|^/adm/|) {              if ($env{'user.priv.'.$env{'request.role'}.'./'}
  $thisallowed='F';                    =~/\Q$priv\E\&([^\:]*)/) {
     } else {                  $thisallowed.=$1;
                 $refuri=&declutter($refuri);              }
                 my ($match) = &is_on_map($refuri);          } else {
                 if ($match) {              my $refuri=$env{'httpref.'.$orguri};
               if ($refuri) {
                   if ($refuri =~ m|^/adm/|) {
                     $thisallowed='F';                      $thisallowed='F';
                   } else {
                       $refuri=&declutter($refuri);
                       my ($match) = &is_on_map($refuri);
                       if ($match) {
                           $thisallowed='F';
                       }
                 }                  }
     }              }
  }          }
     }      }
   
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
Line 3281  sub allowed { Line 3294  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\Q$rolecode\E/) {     =~/\Q$rolecode\E/) {
            &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},             &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.                  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                 $env{'request.course.id'});                  $env{'request.course.id'});
            return '';             return '';
Line 3289  sub allowed { Line 3302  sub allowed {
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\Q$unamedom\E/) {
            &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},             &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.                  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
                 $env{'request.course.id'});                  $env{'request.course.id'});
            return '';             return '';
Line 3301  sub allowed { Line 3314  sub allowed {
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$env{'request.role'}))[0];         my $rolecode=(split(/\./,$env{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
   &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},     &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
           return '';            return '';
        }         }
    }     }
Line 3644  sub auto_instcode_format { Line 3657  sub auto_instcode_format {
   
 sub plaintext {  sub plaintext {
     my $short=shift;      my $short=shift;
     return &mt($prp{$short});      return &Apache::lonlocal::mt($prp{$short});
 }  }
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
Line 3962  sub createcourse { Line 3975  sub createcourse {
         return 'refused';          return 'refused';
     }      }
 # ------------------------------------------------------------------- Create ID  # ------------------------------------------------------------------- Create ID
    my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).     my $uname=int(1+rand(9)).
          ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
          substr($$.time,0,5).unpack("H8",pack("I32",time)).
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 # ----------------------------------------------- Make sure that does not exist  # ----------------------------------------------- Make sure that does not exist
    my $uhome=&homeserver($uname,$udom,'true');     my $uhome=&homeserver($uname,$udom,'true');
Line 4470  sub get_userresdata { Line 4485  sub get_userresdata {
     }      }
     #error 2 occurs when the .db doesn't exist      #error 2 occurs when the .db doesn't exist
     if ($tmp!~/error: 2 /) {      if ($tmp!~/error: 2 /) {
  &logthis("<font color=blue>WARNING:".   &logthis("<font color=\"blue\">WARNING:".
  " Trying to get resource data for ".   " Trying to get resource data for ".
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
Line 4624  sub EXT { Line 4639  sub EXT {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     if ($qualifier eq 'textremote') {      if ($qualifier eq 'textremote') {
  if (&mt('textual_remote_display') eq 'on') {   if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
     return 1;      return 1;
  } else {   } else {
     return 0;      return 0;
Line 5365  sub numval3 { Line 5380  sub numval3 {
     return $total;      return $total;
 }  }
   
   sub digest {
       my ($data)=@_;
       my $digest=&Digest::MD5::md5($data);
       my ($a,$b,$c,$d)=unpack("iiii",$digest);
       my ($e,$f);
       {
           use integer;
           $e=($a+$b);
           $f=($c+$d);
           if ($_64bit) {
               $e=(($e<<32)>>32);
               $f=(($f<<32)>>32);
           }
       }
       if (wantarray) {
    return ($e,$f);
       } else {
    my $g;
    {
       use integer;
       $g=($e+$f);
       if ($_64bit) {
    $g=(($g<<32)>>32);
       }
    }
    return $g;
       }
   }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit4';      return '64bit5';
 }  }
   
 sub get_rand_alg {  sub get_rand_alg {
Line 5406  sub rndseed { Line 5450  sub rndseed {
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=&get_rand_alg();      my $which=&get_rand_alg();
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
  if ($which eq '64bit4') {   if ($which eq '64bit5') {
       return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
    } elsif ($which eq '64bit4') {
     return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
  } else {   } else {
     return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
  }   }
       } elsif ($which eq '64bit5') {
    return &rndseed_64bit5($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit4') {      } elsif ($which eq '64bit4') {
  return &rndseed_64bit4($symb,$courseid,$domain,$username);   return &rndseed_64bit4($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit3') {      } elsif ($which eq '64bit3') {
Line 5533  sub rndseed_64bit4 { Line 5581  sub rndseed_64bit4 {
     }      }
 }  }
   
   sub rndseed_64bit5 {
       my ($symb,$courseid,$domain,$username)=@_;
       my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
       return "$num1:$num2";
   }
   
 sub rndseed_CODE_64bit {  sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     {      {
Line 5571  sub rndseed_CODE_64bit4 { Line 5625  sub rndseed_CODE_64bit4 {
     }      }
 }  }
   
   sub rndseed_CODE_64bit5 {
       my ($symb,$courseid,$domain,$username)=@_;
       my $code = &getCODE();
       my ($num1,$num2)=&digest("$symb,$courseid,$code");
       return "$num1:$num2";
   }
   
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
Line 5909  sub thaw_unescape { Line 5970  sub thaw_unescape {
     return &unescape($value);      return &unescape($value);
 }  }
   
 sub mod_perl_version {  
     return 1;  
     if (defined($perlvar{'MODPERL2'})) {  
  return 2;  
     }  
 }  
   
 sub correct_line_ends {  sub correct_line_ends {
     my ($result)=@_;      my ($result)=@_;
     $$result =~s/\r\n/\n/mg;      $$result =~s/\r\n/\n/mg;
Line 6114  $processmarker='_'.time.'_'.$perlvar{'lo Line 6168  $processmarker='_'.time.'_'.$perlvar{'lo
 $dumpcount=0;  $dumpcount=0;
   
 &logtouch();  &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color="yellow">INFO: Read configuration</font>');
 $readit=1;  $readit=1;
     {      {
  use integer;   use integer;
Removed from v.1.669  
changed lines
  Added in v.1.677

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