[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.683.2.12 and 1.685

version 1.683.2.12, 2006/01/13 19:22:29 version 1.685, 2005/12/09 00:08:51
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],2);   my ($envname,$envvalue)=split(/=/,$profile[$envi]);
  $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 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],2);      my ($name,$value)=split(/=/,$oldenv[$i]);
     unless (defined($newenv{$name})) {      unless (defined($newenv{$name})) {
  $newenv{$name}=$value;   $newenv{$name}=$value;
     }      }
Line 382  sub delenv { Line 382  sub delenv {
  }   }
  foreach (@oldenv) {   foreach (@oldenv) {
     if ($_=~/^$delthis/) {       if ($_=~/^$delthis/) { 
                 my ($key,undef) = split('=',$_,2);                  my ($key,undef) = split('=',$_);
                 delete($env{$key});                  delete($env{$key});
             } else {              } else {
                 print $fh $_;                   print $fh $_; 
Line 3010  sub tmpput { Line 3010  sub tmpput {
   
 # ------------------------------------------------------------ tmpget interface  # ------------------------------------------------------------ tmpget interface
 sub tmpget {  sub tmpget {
     my ($token,$server)=@_;      my ($token)=@_;
     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }      my $rep=&reply("tmpget:$token",$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 3021  sub tmpget { Line 3020  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 3346  sub allowed { Line 3338  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/) {
    if ($priv ne 'pch') {              &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
        &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 '';
        }         }
   
        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/) {
    if ($priv ne 'pch') {              &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
        &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 3370  sub allowed { Line 3358  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/) {
    if ($priv ne 'pch') {      &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
        &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 3405  sub is_on_map { Line 3391  sub is_on_map {
     my $filename=$uriparts[$#uriparts];      my $filename=$uriparts[$#uriparts];
     my $pathname=$uri;      my $pathname=$uri;
     $pathname=~s|/\Q$filename\E$||;      $pathname=~s|/\Q$filename\E$||;
     $pathname=~s/^adm\/wrapper\///;      $pathname=~s/^adm\/wrapper\///;    
     $pathname=~s/^adm\/coursedocs\/showdoc\///;  
     #Trying to find the conditional for the file      #Trying to find the conditional for the file
     my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~      my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
        /\&\Q$filename\E\:([\d\|]+)\&/);         /\&\Q$filename\E\:([\d\|]+)\&/);
Line 3730  sub modify_group_roles { Line 3715  sub modify_group_roles {
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
       if ($result eq 'ok') {
           &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
       }
   
     return $result;      return $result;
 }  }
   
Line 4813  sub EXT { Line 4802  sub EXT {
         return $env{'course.'.$courseid.'.'.$spacequalifierrest};          return $env{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  my $section;   my ($section,$group);
           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 4833  sub EXT { Line 4823  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'});
                   if (@groups > 0) {
                       @groups = sort(@groups);
                       $group = $groups[0];
                   }
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&getsection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
  } else {   } else {
     $section = $usection;      $section = $usection;
  }   }
                   my $grouplist = &get_users_groups($udom,$uname,$courseid);
                   if ($grouplist) {
                       @groups = split(/:/,$grouplist);
                       @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 4858  sub EXT { Line 4863  sub EXT {
     if (defined($userreply)) { return $userreply; }      if (defined($userreply)) { return $userreply; }
   
 # ------------------------------------------------ second, check some of course  # ------------------------------------------------ second, check some of course
               my $coursereply;
               if (defined($group)) {
                   $coursereply = &resdata($env{'course.'.$courseid.'.num'},
                                        $env{'course.'.$courseid.'.domain'},
                                        'course',
                                        ($grplevelr,$grplevelm,$grplevel,
                                         $courselevelr));
                   if (defined($coursereply)) { return $coursereply; }
               }
   
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},       $env{'course.'.$courseid.'.domain'},
      'course',       'course',
      ($seclevelr,$seclevelm,$seclevel,       ($seclevelr,$seclevelm,$seclevel,
Line 4930  sub EXT { Line 4944  sub EXT {
  if ($space eq 'time') {   if ($space eq 'time') {
     return time;      return time;
         }          }
     } elsif ($realm eq 'server') {  
 # ----------------------------------------------------------------- system.time  
  if ($space eq 'name') {  
     return $ENV{'SERVER_NAME'};  
         }  
     }      }
     return '';      return '';
 }  }
Line 5166  sub metadata { Line 5175  sub metadata {
  $metaentry{':keys'}=join(',',keys %metathesekeys);   $metaentry{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60);   &do_cache_new('meta',$uri,\%metaentry,60*60*24);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 5299  sub symbverify { Line 5308  sub symbverify {
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
 # wrapper not part of symbs  # wrapper not part of symbs
     $thisfn=~s/^\/adm\/wrapper//;      $thisfn=~s/^\/adm\/wrapper//;
     $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;  
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
Line 5354  sub symbclean { Line 5362  sub symbclean {
 # remove wrapper  # remove wrapper
   
     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;      $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
     $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;  
     return $symb;      return $symb;
 }  }
   
Line 5431  sub symbread { Line 5438  sub symbread {
         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {          if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
             $targetfn = 'adm/wrapper/'.$thisfn;              $targetfn = 'adm/wrapper/'.$thisfn;
         }          }
  if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {  
     $targetfn=$1;  
  }  
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_READER(),0640)) {                        &GDBM_READER(),0640)) {
     $syval=$hash{$targetfn};      $syval=$hash{$targetfn};
Line 6005  sub filelocation { Line 6009  sub filelocation {
     my ($dir,$file) = @_;      my ($dir,$file) = @_;
     my $location;      my $location;
     $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces      $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
   
     if ($file =~ m-^/adm/-) {  
  $file=~s-^/adm/wrapper/-/-;  
  $file=~s-^/adm/coursedocs/showdoc/-/-;  
     }  
     if ($file=~m:^/~:) { # is a contruction space reference      if ($file=~m:^/~:) { # is a contruction space reference
         $location = $file;          $location = $file;
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;          $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
Line 6049  sub hreflocation { Line 6048  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {      unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
  $file=filelocation($dir,$file);   $file=filelocation($dir,$file);
     } elsif ($file=~m-^/adm/-) {  
  $file=~s-^/adm/wrapper/-/-;  
  $file=~s-^/adm/coursedocs/showdoc/-/-;  
     }      }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
Line 6095  sub declutter { Line 6091  sub declutter {
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;      $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s|^adm/wrapper/||;  
     $thisfn=~s|^adm/coursedocs/showdoc/||;  
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
     $thisfn=~s/\?.+$//;      $thisfn=~s/\?.+$//;
     return $thisfn;      return $thisfn;
Line 6109  sub clutter { Line 6103  sub clutter {
     unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) {       unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
     if ($thisfn !~m|/adm|) {  
  if ($thisfn =~ m|/ext/|) {  
     $thisfn='/adm/wrapper'.$thisfn;  
  } else {  
     my ($ext) = ($thisfn =~ /\.(\w+)$/);  
     my $embstyle=&Apache::loncommon::fileembstyle($ext);  
     if ($embstyle eq 'ssi'  
  || ($embstyle eq 'hdn')  
  || ($embstyle eq 'rat')  
  || ($embstyle eq 'prv')  
  || ($embstyle eq 'ign')) {  
  #do nothing with these  
     } elsif (($embstyle eq 'img')   
  || ($embstyle eq 'emb')  
  || ($embstyle eq 'wrp')) {  
  $thisfn='/adm/wrapper'.$thisfn;  
     } elsif ($embstyle eq 'unk'  
      && $thisfn!~/\.(sequence|page)$/) {  
  $thisfn='/adm/coursedocs/showdoc'.$thisfn;  
     } else {  
  #&logthis("Got a blank emb style");  
     }  
  }  
     }  
     return $thisfn;      return $thisfn;
 }  }
   
Line 6276  BEGIN { Line 6246  BEGIN {
     }      }
     close($config);      close($config);
     # FIXME: dev server don't want this, production servers _do_ want this      # FIXME: dev server don't want this, production servers _do_ want this
     &get_iphost();      #&get_iphost();
 }  }
   
 sub get_iphost {  sub get_iphost {
Removed from v.1.683.2.12  
changed lines
  Added in v.1.685

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