[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.89 and 1.99

version 1.89, 2001/01/09 19:55:31 version 1.99, 2001/01/19 21:19:28
Line 84 Line 84
 # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer  # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
 # 05/01/01 Guy Albertelli  # 05/01/01 Guy Albertelli
 # 05/01,06/01,09/01 Gerd Kortemeyer  # 05/01,06/01,09/01 Gerd Kortemeyer
   # 09/01 Guy Albertelli
   # 09/01,10/01,11/01 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 243  sub appenv { Line 245  sub appenv {
             $ENV{$_}=$newenv{$_};              $ENV{$_}=$newenv{$_};
         }          }
     } keys %newenv;      } keys %newenv;
   
       my $lockfh;
       unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
          return 'error: '.$!;
       }
       unless (flock($lockfh,LOCK_EX)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain exclusive lock in appenv: '.$!);
            $lockfh->close();
            return 'error: '.$!;
       }
   
     my @oldenv;      my @oldenv;
     {      {
      my $fh;       my $fh;
      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {       unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
  return 'error';   return 'error: '.$!;
      }  
      unless (flock($fh,LOCK_SH)) {  
          &logthis("<font color=blue>WARNING: ".  
                   'Could not obtain shared lock in appenv: '.$!);  
          $fh->close();  
          return 'error: '.$!;  
      }       }
      @oldenv=<$fh>;       @oldenv=<$fh>;
      $fh->close();       $fh->close();
Line 273  sub appenv { Line 281  sub appenv {
  return 'error';   return 'error';
      }       }
      my $newname;       my $newname;
      unless (flock($fh,LOCK_EX)) {  
          &logthis("<font color=blue>WARNING: ".  
                   'Could not obtain exclusive lock in appenv: '.$!);  
          $fh->close();  
          return 'error: '.$!;  
      }  
      foreach $newname (keys %newenv) {       foreach $newname (keys %newenv) {
  print $fh "$newname=$newenv{$newname}\n";   print $fh "$newname=$newenv{$newname}\n";
      }       }
      $fh->close();       $fh->close();
     }      }
   
       $lockfh->close();
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
Line 689  sub coursedescription { Line 693  sub coursedescription {
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        my $rep=reply("dump:$cdomain:$cnum:environment",$chome);         my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
        if ($rep ne 'con_lost') {         if ($rep ne 'con_lost') {
            my $normalid=$courseid;             my $normalid=$cdomain.'_'.$cnum;
            $normalid=~s/\//\_/g;  
            my %envhash=();             my %envhash=();
            my %returnhash=('home'   => $chome,              my %returnhash=('home'   => $chome, 
                            'domain' => $cdomain,                             'domain' => $cdomain,
Line 1039  sub allowed { Line 1042  sub allowed {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                  $courseid=~s/^\///;
                my $expiretime=600;                 my $expiretime=600;
                if ($ENV{'request.role'} eq $roleid) {                 if ($ENV{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
Line 1612  sub EXT { Line 1616  sub EXT {
        my $courselevelm=         my $courselevelm=
             $ENV{'request.course.id'}.'.'.$mapparm;              $ENV{'request.course.id'}.'.'.$mapparm;
   
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
       my %resourcedata=get('resourcedata',        my %resourcedata=get('resourcedata',
                            ($courselevelr,$courselevelm,$courselevel));                             ($courselevelr,$courselevelm,$courselevel));
       if ($resourcedata{$courselevelr}!~/^error\:/) {        if (($resourcedata{$courselevelr}!~/^error\:/) &&
             ($resourcedata{$courselevelr}!~/^con_lost/)) {
   
        if ($resourcedata{$courselevelr}) {          if ($resourcedata{$courselevelr}) { 
           return $resourcedata{$courselevelr}; }            return $resourcedata{$courselevelr}; }
Line 1624  sub EXT { Line 1628  sub EXT {
           return $resourcedata{$courselevelm}; }            return $resourcedata{$courselevelm}; }
        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }         if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
   
         } else {
     if ($resourcedata{$courselevelr}!~/No such file/) {
       &logthis("<font color=blue>WARNING:".
      " Trying to get resource data for ".$ENV{'user.name'}." at "
                      .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
                    "</font>");
     }
       }        }
   
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
         my $section='';  
         if ($ENV{'request.course.sec'}) {  
     $section='_'.$ENV{'request.course.sec'};  
         }  
         my $reply=&reply('get:'.          my $reply=&reply('get:'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.                $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.                $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
       ':resourcedata:'.        ':resourcedata:'.
    &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.     &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
    &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),     &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
    $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});     $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
       if ($reply!~/^error\:/) {        if ($reply!~/^error\:/) {
   map {    map {
       if ($_) { return &unescape($_); }        if ($_) { return &unescape($_); }
           } split(/\&/,$reply);            } split(/\&/,$reply);
       }        }
         if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
     &logthis("<font color=blue>WARNING:".
                   " Getting ".$reply." asking for ".$varname." for ".
                   $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
                   ' at '.
                   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
                   ' from '.
                   $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
                    "</font>");
         }
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
        my %parmhash=();         my %parmhash=();
        my $thisparm='';                my $thisparm='';       
Line 1825  sub numval { Line 1843  sub numval {
 sub rndseed {  sub rndseed {
     my $symb;      my $symb;
     unless ($symb=&symbread()) { return time; }      unless ($symb=&symbread()) { return time; }
     my $symbchck=unpack("%32C*",$symb);      { 
     my $symbseed=numval($symb)%$symbchck;        use integer;
     my $namechck=unpack("%32C*",$ENV{'user.name'});        my $symbchck=unpack("%32C*",$symb) << 27;
     my $nameseed=numval($ENV{'user.name'})%$namechck;        my $symbseed=numval($symb)%$symbchck << 22;
     return int( $symbseed        my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;
        .$nameseed        my $nameseed=numval($ENV{'user.name'})%$namechck << 12;
                .unpack("%32C*",$ENV{'user.domain'})        my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;
                .unpack("%32C*",$ENV{'request.course.id'})        my $courseseed=unpack("%32C*",$ENV{'request.course.id'});
                .$namechck        my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
                .$symbchck);        #uncommenting these lines can break things!
         #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
         #&Apache::lonxml::debug("rndseed :$num:$symb");
         return $num;
       }
 }  }
   
 sub ireceipt {  sub ireceipt {
Removed from v.1.89  
changed lines
  Added in v.1.99

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