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

version 1.683.2.13, 2006/01/26 06:34:33 version 1.692, 2006/01/10 16:06:07
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 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('=',$_,2);                  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 1280  sub clean_filename { Line 1280  sub clean_filename {
 }  }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: name of form element, coursedoc=1 means this is for the course  # input: $formname - the contents of the file are in $env{"form.$formname"}
 # output: url of file in userspace  #                    the desired filenam is in $env{"form.$formname"}
   #        $coursedoc - if true up to the current course
   #                     if false
   #        $subdir - directory in userfile to store the file into
   #        $parser, $allfiles, $codebase - unknown
   #
   # output: url of file in userspace, or error: <message> 
   #             or /adm/notfound.html if failure to upload occurse
   
   
 sub userfileupload {  sub userfileupload {
Line 3405  sub is_on_map { Line 3412  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 3736  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 4814  sub EXT { Line 4824  sub EXT {
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  my $section;   my $section;
           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 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=&sort_course_groups($env{'request.course.groups'},$courseid); 
                   if (@groups > 0) {
                       @groups = sort(@groups);
                   }
     } 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=&sort_course_groups($grouplist,$courseid);
                   }
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 4854  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;
               if (@groups > 0) {
                   $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                          $mapparm,$spacequalifierrest);
                   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 4954  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 '';
 }  }
   
   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);
Line 5166  sub metadata { Line 5211  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 5262  sub get_slot { Line 5307  sub get_slot {
  $cdom=$env{'course.'.$courseid.'.domain'};   $cdom=$env{'course.'.$courseid.'.domain'};
  $cnum=$env{'course.'.$courseid.'.num'};   $cnum=$env{'course.'.$courseid.'.num'};
     }      }
     my $key=join("\0",'slots',$cdom,$cnum,$which);      my %slotinfo=&get('slots',[$which],$cdom,$cnum);
     my %slotinfo;      &Apache::lonhomework::showhash(%slotinfo);
     if (exists($remembered{$key})) {      my ($tmp)=keys(%slotinfo);
  $slotinfo{$which} = $remembered{$key};      if ($tmp=~/^error:/) { return (); }
     } else {  
  %slotinfo=&get('slots',[$which],$cdom,$cnum);  
  &Apache::lonhomework::showhash(%slotinfo);  
  my ($tmp)=keys(%slotinfo);  
  if ($tmp=~/^error:/) { return (); }  
  $remembered{$key} = $slotinfo{$which};  
     }  
     if (ref($slotinfo{$which}) eq 'HASH') {      if (ref($slotinfo{$which}) eq 'HASH') {
  return %{$slotinfo{$which}};   return %{$slotinfo{$which}};
     }      }
Line 5306  sub symbverify { Line 5344  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 5361  sub symbclean { Line 5398  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 6012  sub filelocation { Line 6048  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 6056  sub hreflocation { Line 6087  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 6102  sub declutter { Line 6130  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 6116  sub clutter { Line 6142  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 6283  BEGIN { Line 6285  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.13  
changed lines
  Added in v.1.692

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