[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.5 and 1.694

version 1.683.2.5, 2006/01/05 19:39:52 version 1.694, 2006/01/10 21:41:39
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 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 3729  sub modify_group_roles { Line 3737  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 4812  sub EXT { Line 4824  sub EXT {
         return $env{'course.'.$courseid.'.'.$spacequalifierrest};          return $env{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  my $section;  
  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(); }
  }   }
   
    if ($space eq 'title') {
       if (!$symbparm) { $symbparm = $env{'request.filename'}; }
       return &gettitle($symbparm);
    }
   
    if ($space eq 'map') {
       my ($map) = &decode_symb($symbparm);
       return &symbread($map);
    }
   
    my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $env{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
Line 4832  sub EXT { Line 4855  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 4853  sub EXT { Line 4884  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 4933  sub EXT { Line 4969  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);
Line 4975  sub metadata { Line 5037  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)
     && ($uri !~ m|^adm/coursedocs/|) && ($uri !~ m|^adm/wrapper/|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|)) {   ($uri =~ m|home/[^/]+/public_html/|)) {
  return undef;   return undef;
Line 5293  sub symbverify { Line 5356  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 5347  sub symbclean { Line 5411  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 6081  sub declutter { Line 6146  sub declutter {
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
     $thisfn=~s/\?.+$//;      $thisfn=~s/\?.+$//;
       $thisfn=~s|adm/wrapper/||;
       $thisfn=~s|adm/coursedocs/showdoc/||;
     return $thisfn;      return $thisfn;
 }  }
   
Line 6091  sub clutter { Line 6158  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|) {
    my ($ext) = ($thisfn =~ /\.(\w+)$/);
    my $embstyle=&Apache::loncommon::fileembstyle($ext);
    if (($embstyle eq 'img') 
       || ($embstyle eq 'emb')
       || ($embstyle eq 'wrp')) {
       $thisfn='/adm/wrapper'.$thisfn;
    } elsif ($embstyle eq 'ssi') {
       #do nothing with these
    } elsif ($thisfn!~/\.(sequence|page)$/) {
       $thisfn='/adm/coursedocs/showdoc'.$thisfn;
    }
       }
   
     return $thisfn;      return $thisfn;
 }  }
   
Line 6234  BEGIN { Line 6315  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.5  
changed lines
  Added in v.1.694

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