[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.362 and 1.370

version 1.362, 2003/04/18 01:13:21 version 1.370, 2003/05/08 21:50:54
Line 347  sub delenv { Line 347  sub delenv {
     return 'ok';      return 'ok';
 }  }
   
   # ------------------------------------------ Find out current server userload
   # there is a copy in lond
   sub userload {
       my $numusers=0;
       {
    opendir(LONIDS,$perlvar{'lonIDsDir'});
    my $filename;
    my $curtime=time;
    while ($filename=readdir(LONIDS)) {
       if ($filename eq '.' || $filename eq '..') {next;}
       my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
       if ($curtime-$atime < 3600) { $num_users++; }
    }
    closedir(LONIDS);
       }
       my $userloadpercent=0;
       my $maxuserload=$perlvar{'lonUserLoadLim'};
       if ($maxuserload) {
    $userloadpercent=100*$num_users/$maxuserload;
       }
       return $userloadpercent;
   }
   
 # ------------------------------------------ Fight off request when overloaded  # ------------------------------------------ Fight off request when overloaded
   
 sub overloaderror {  sub overloaderror {
Line 373  sub overloaderror { Line 396  sub overloaderror {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my $loadpercent = shift;      my ($loadpercent,$userloadpercent) = @_;
     my $tryserver;      my $tryserver;
     my $spareserver='';      my $spareserver='';
     my $lowestserver=$loadpercent;       if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
       my $lowestserver=$loadpercent > $userloadpercent?
                $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys %spareid) {
        my $answer=reply('load',$tryserver);         my $loadans=reply('load',$tryserver);
          my $userloadans=reply('userload',$tryserver);
          if ($userloadans !~ /\d/) { $userloadans=0; }
          my $answer=$loadans > $userloadans?
                     $loadans :  $userloadans;
        if (($answer =~ /\d/) && ($answer<$lowestserver)) {         if (($answer =~ /\d/) && ($answer<$lowestserver)) {
    $spareserver="http://$hostname{$tryserver}";     $spareserver="http://$hostname{$tryserver}";
            $lowestserver=$answer;             $lowestserver=$answer;
        }         }
     }          }
     return $spareserver;      return $spareserver;
 }  }
   
Line 591  sub idput { Line 620  sub idput {
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;  #
   # a valid key looks like uname:udom#comments
   # comments are being appended
   #
       my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
Line 599  sub assign_access_key { Line 632  sub assign_access_key {
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     if (($existing{$ckey}=~/^\d+$/) || # has time - new key      if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
         ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen,          ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { 
                                                     # assigned to this person
                                                     # - this should not happen,
                                                   # unless something went wrong                                                    # unless something went wrong
                                                   # the first time around                                                    # the first time around
 # ready to assign  # ready to assign
     } elsif (!$existing{$ckey}) {          $logentry=$1.'; '.$logentry;
         if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') {          if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},
                                                    $cdom,$cnum) eq 'ok') {
 # key now belongs to user  # key now belongs to user
     my $envkey='key.'.$cdom.'_'.$cnum;      my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {              if (&put('environment',{$envkey => $ckey}) eq 'ok') {
Line 618  sub assign_access_key { Line 654  sub assign_access_key {
         } else {          } else {
             return 'error: Could not assign key, try again later.';              return 'error: Could not assign key, try again later.';
         }          }
       } elsif (!$existing{$ckey}) {
 # the key does not exist  # the key does not exist
  return 'error: The key does not exist';   return 'error: The key does not exist';
     } else {      } else {
Line 626  sub assign_access_key { Line 663  sub assign_access_key {
     }      }
 }  }
   
   # ------------------------------------------ put an additional comment on a key
   
   sub comment_access_key {
   #
   # a valid key looks like uname:udom#comments
   # comments are being appended
   #
       my ($ckey,$cdom,$cnum,$logentry)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       if ($existing{$ckey}) {
           $existing{$ckey}.='; '.$logentry;
   # ready to assign
           if (&put('accesskeys',{$ckey=>$existing{$ckey}},
                                                    $cdom,$cnum) eq 'ok') {
       return 'ok';
           } else {
       return 'error: Count not store comment.';
           }
       } else {
   # the key does not exist
    return 'error: The key does not exist';
       }
   }
   
 # ------------------------------------------------------ Generate a set of keys  # ------------------------------------------------------ Generate a set of keys
   
 sub generate_access_keys {  sub generate_access_keys {
     my ($number,$cdom,$cnum)=@_;      my ($number,$cdom,$cnum,$logentry)=@_;
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
Line 650  sub generate_access_keys { Line 715  sub generate_access_keys {
        if ($existing{$newkey}) {         if ($existing{$newkey}) {
            $i--;             $i--;
        } else {         } else {
   if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') {    if (&put('accesskeys',
                 { $newkey => '# generated '.localtime().
                              ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}.
                              '; '.$logentry },
      $cdom,$cnum) eq 'ok') {
               $total++;                $total++;
   }    }
        }         }
Line 671  sub validate_access_key { Line 740  sub validate_access_key {
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     return ($existing{$ckey} eq $uname.':'.$udom);      return ($existing{$ckey}=~/^$uname\:$udom\#/);
 }  }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
Line 3371  sub metadata { Line 3440  sub metadata {
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
    delete($metacache{$uri.':packages'});
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
     if ($token->[0] eq 'S') {      if ($token->[0] eq 'S') {
  if (defined($token->[2]->{'package'})) {   if (defined($token->[2]->{'package'})) {
Line 3546  sub gettitle { Line 3616  sub gettitle {
         $title=$bighash{'title_'.$mapid.'.'.$resid};          $title=$bighash{'title_'.$mapid.'.'.$resid};
         untie %bighash;          untie %bighash;
     }      }
       $title=~s/\&colon\;/\:/gs;
     if ($title) {      if ($title) {
         $titlecache{$symb}=$title;          $titlecache{$symb}=$title;
         return $title;          return $title;
Line 3719  sub numval { Line 3790  sub numval {
     $txt=~tr/u-z/0-5/;      $txt=~tr/u-z/0-5/;
     $txt=~s/\D//g;      $txt=~s/\D//g;
     return int($txt);      return int($txt);
 }      }
   
   sub latest_rnd_algorithm_id {
       return '64bit';
   }
   
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
   
       my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
     if (!$symb) {      if (!$symb) {
       unless ($symb=&symbread()) { return time; }   unless ($symb=$wsymb) { return time; }
       }
       if (!$courseid) { $courseid=$wcourseid; }
       if (!$domain) { $domain=$wdomain; }
       if (!$username) { $username=$wusername }
       my $which=$ENV{"course.$courseid.rndseed"};
       my $CODE=$ENV{'scantron.CODE'};
       if (defined($CODE)) {
    &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
       } elsif ($which eq '64bit') {
    return &rndseed_64bit($symb,$courseid,$domain,$username);
       }
       return &rndseed_32bit($symb,$courseid,$domain,$username);
   }
   
   sub rndseed_32bit {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32C*",$symb) << 27;
    my $symbseed=numval($symb) << 22;
    my $namechck=unpack("%32C*",$username) << 17;
    my $nameseed=numval($username) << 12;
    my $domainseed=unpack("%32C*",$domain) << 7;
    my $courseseed=unpack("%32C*",$courseid);
    my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
    #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num:$symb");
    return $num;
     }      }
     if (!$courseid) { $courseid=$ENV{'request.course.id'};}  }
     if (!$domain) {$domain=$ENV{'user.domain'};}  
     if (!$username) {$username=$ENV{'user.name'};}  sub rndseed_64bit {
       my ($symb,$courseid,$domain,$username)=@_;
     {      {
       use integer;   use integer;
       my $symbchck=unpack("%32C*",$symb) << 27;   my $symbchck=unpack("%32S*",$symb) << 21;
       my $symbseed=numval($symb) << 22;   my $symbseed=numval($symb) << 10;
       my $namechck=unpack("%32C*",$username) << 17;   my $namechck=unpack("%32S*",$username);
       my $nameseed=numval($username) << 12;  
       my $domainseed=unpack("%32C*",$domain) << 7;   my $nameseed=numval($username) << 21;
       my $courseseed=unpack("%32C*",$courseid);   my $domainseed=unpack("%32S*",$domain) << 10;
       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   my $courseseed=unpack("%32S*",$courseid);
       #uncommenting these lines can break things!  
       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   my $num1=$symbchck+$symbseed+$namechck;
       #&Apache::lonxml::debug("rndseed :$num:$symb");   my $num2=$nameseed+$domainseed+$courseseed;
       return $num;   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num:$symb");
    return "$num1,$num2";
       }
   }
   
   sub rndseed_CODE_64bit {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32S*",$symb) << 16;
    my $symbseed=numval($symb);
    my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
    my $courseseed=unpack("%32S*",$courseid);
    my $num1=$symbseed+$CODEseed;
    my $num2=$courseseed+$symbchck;
    #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
    return "$num1,$num2";
       }
   }
   
   sub setup_random_from_rndseed {
       my ($rndseed)=@_;
       if ($rndseed =~/,/) {
    my ($num1,$num2)=split(/,/,$rndseed);
    &Math::Random::random_set_seed(abs($num1),abs($num2));
       } else {
    &Math::Random::random_set_seed_from_phrase($rndseed);
     }      }
 }  }
   
Removed from v.1.362  
changed lines
  Added in v.1.370

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