[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.687 and 1.692

version 1.687, 2005/12/22 20:56:28 version 1.692, 2006/01/10 16:06:07
Line 271  sub transfer_profile_to_env { Line 271  sub transfer_profile_to_env {
     my %Remove;      my %Remove;
     for ($envi=0;$envi<=$#profile;$envi++) {      for ($envi=0;$envi<=$#profile;$envi++) {
  chomp($profile[$envi]);   chomp($profile[$envi]);
  my ($envname,$envvalue)=split(/=/,$profile[$envi]);   my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
  $env{$envname} = $envvalue;   $env{$envname} = $envvalue;
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
Line 289  sub transfer_profile_to_env { Line 289  sub transfer_profile_to_env {
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my %newenv=@_;
     foreach (keys %newenv) {      foreach my $key (keys(%newenv)) {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
             &logthis("<font color=\"blue\">WARNING: ".              &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_}                  "Attempt to modify environment ".$key." to ".$newenv{$key}
                 .'</font>');                  .'</font>');
     delete($newenv{$_});      delete($newenv{$key});
         } else {          } else {
             $env{$_}=$newenv{$_};              $env{$key}=$newenv{$key};
         }          }
     }      }
   
Line 323  sub appenv { Line 323  sub appenv {
     for (my $i=0; $i<=$#oldenv; $i++) {      for (my $i=0; $i<=$#oldenv; $i++) {
         chomp($oldenv[$i]);          chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {          if ($oldenv[$i] ne '') {
     my ($name,$value)=split(/=/,$oldenv[$i]);      my ($name,$value)=split(/=/,$oldenv[$i],2);
     unless (defined($newenv{$name})) {      unless (defined($newenv{$name})) {
  $newenv{$name}=$value;   $newenv{$name}=$value;
     }      }
Line 380  sub delenv { Line 380  sub delenv {
     close($fh);      close($fh);
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach (@oldenv) {   foreach my $cur_key (@oldenv) {
     if ($_=~/^$delthis/) {       if ($cur_key=~/^$delthis/) { 
                 my ($key,undef) = split('=',$_);                  my ($key,undef) = split('=',$cur_key,2);
                 delete($env{$key});                  delete($env{$key});
             } else {              } else {
                 print $fh $_;                   print $fh $cur_key; 
             }              }
  }   }
  close($fh);   close($fh);
Line 3017  sub tmpput { Line 3017  sub tmpput {
   
 # ------------------------------------------------------------ tmpget interface  # ------------------------------------------------------------ tmpget interface
 sub tmpget {  sub tmpget {
     my ($token)=@_;      my ($token,$server)=@_;
     my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
       my $rep=&reply("tmpget:$token",$server);
     my %returnhash;      my %returnhash;
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
Line 3027  sub tmpget { Line 3028  sub tmpget {
     return %returnhash;      return %returnhash;
 }  }
   
   # ------------------------------------------------------------ tmpget interface
   sub tmpdel {
       my ($token,$server)=@_;
       if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
       return &reply("tmpdel:$token",$server);
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 3345  sub allowed { Line 3353  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/) {
            &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.     if ($priv ne 'pch') { 
                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                 $env{'request.course.id'});   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
    $env{'request.course.id'});
      }
            return '';             return '';
        }         }
   
        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/) {
            &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.     if ($priv ne 'pch') { 
                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
                 $env{'request.course.id'});   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
    $env{'request.course.id'});
      }
            return '';             return '';
        }         }
    }     }
Line 3365  sub allowed { Line 3377  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/) {
    &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.     if ($priv ne 'pch') { 
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
           return '';   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
      }
      return '';
        }         }
    }     }
   
Line 4809  sub EXT { Line 4823  sub EXT {
         return $env{'course.'.$courseid.'.'.$spacequalifierrest};          return $env{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  my ($section,$group);   my $section;
         my @groups = ();          my @groups = ();
  if (defined($courseid) && $courseid eq $env{'request.course.id'}) {   if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
Line 4830  sub EXT { Line 4844  sub EXT {
     if (($env{'user.name'} eq $uname) &&      if (($env{'user.name'} eq $uname) &&
  ($env{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$env{'request.course.sec'};   $section=$env{'request.course.sec'};
                 @groups=split(/:/,$env{'request.course.groups'});                  @groups=&sort_course_groups($env{'request.course.groups'},$courseid); 
                 if (@groups > 0) {                  if (@groups > 0) {
                     @groups = sort(@groups);                      @groups = sort(@groups);
                     $group = $groups[0];  
                 }                  }
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
Line 4843  sub EXT { Line 4856  sub EXT {
  }   }
                 my $grouplist = &get_users_groups($udom,$uname,$courseid);                  my $grouplist = &get_users_groups($udom,$uname,$courseid);
                 if ($grouplist) {                  if ($grouplist) {
                     @groups = split(/:/,$grouplist);                      @groups=&sort_course_groups($grouplist,$courseid);
                     @groups = sort(@groups);  
                     $group = $groups[0];  
                 }                  }
     }      }
   
             my $grplevel=$courseid.'.['.$group.'].'.$spacequalifierrest;  
             my $grplevelr=$courseid.'.['.$group.'].'.$symbparm;  
             my $grplevelm=$courseid.'.['.$group.'].'.$mapparm;  
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
     my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
     my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
Line 4866  sub EXT { Line 4873  sub EXT {
     my $userreply=&resdata($uname,$udom,'user',      my $userreply=&resdata($uname,$udom,'user',
        ($courselevelr,$courselevelm,         ($courselevelr,$courselevelm,
  $courselevel));   $courselevel));
   
     if (defined($userreply)) { return $userreply; }      if (defined($userreply)) { return $userreply; }
   
 # ------------------------------------------------ second, check some of course  # ------------------------------------------------ second, check some of course
             my $coursereply;              my $coursereply;
             if (defined($group)) {              if (@groups > 0) {
                 $coursereply = &resdata($env{'course.'.$courseid.'.num'},                  $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                      $env{'course.'.$courseid.'.domain'},                                         $mapparm,$spacequalifierrest);
                                      'course',  
                                      ($grplevelr,$grplevelm,$grplevel,  
                                       $courselevelr));  
                 if (defined($coursereply)) { return $coursereply; }                  if (defined($coursereply)) { return $coursereply; }
             }              }
   
Line 4955  sub EXT { Line 4958  sub EXT {
     return '';      return '';
 }  }
   
   sub check_group_parms {
       my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
       my @groupitems = ();
       my $resultitem;
       my @levels = ($symbparm,$mapparm,$what);
       foreach my $group (@{$groups}) {
           foreach my $level (@levels) {
                my $item = $courseid.'.['.$group.'].'.$level;
                push(@groupitems,$item);
           }
       }
       my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
                               $env{'course.'.$courseid.'.domain'},
                                        'course',@groupitems);
       return $coursereply;
   }
   
   sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
       my ($grouplist,$courseid) = @_;
       my @groups = split/:/,$grouplist;
       if (@groups > 1) {
           @groups = sort(@groups);
       }
       return @groups;
   }
   
 sub packages_tab_default {  sub packages_tab_default {
     my ($uri,$varname)=@_;      my ($uri,$varname)=@_;
     my (undef,$part,$name)=split(/\./,$varname);      my (undef,$part,$name)=split(/\./,$varname);
Removed from v.1.687  
changed lines
  Added in v.1.692

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