[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.20 and 1.698

version 1.683.2.20, 2006/04/06 19:19:11 version 1.698, 2006/01/11 20:27:43
Line 272  sub transfer_profile_to_env { Line 272  sub transfer_profile_to_env {
     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],2);
  $envname=&unescape($envname);  
  $envvalue=&unescape($envvalue);  
  $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 291  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 326  sub appenv { Line 324  sub appenv {
         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],2);
     $name=&unescape($name);  
     $value=&unescape($value);  
     unless (defined($newenv{$name})) {      unless (defined($newenv{$name})) {
  $newenv{$name}=$value;   $newenv{$name}=$value;
     }      }
Line 340  sub appenv { Line 336  sub appenv {
  }   }
  my $newname;   my $newname;
  foreach $newname (keys %newenv) {   foreach $newname (keys %newenv) {
     print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";      print $fh "$newname=$newenv{$newname}\n";
  }   }
  close($fh);   close($fh);
     }      }
Line 352  sub appenv { Line 348  sub appenv {
   
 sub delenv {  sub delenv {
     my $delthis=shift;      my $delthis=shift;
       my %newenv=();
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
Line 384  sub delenv { Line 381  sub delenv {
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach my $cur_key (@oldenv) {   foreach my $cur_key (@oldenv) {
     my $unescaped_cur_key = &unescape($cur_key);      if ($cur_key=~/^$delthis/) { 
     if ($unescaped_cur_key=~/^$delthis/) {                   my ($key,undef) = split('=',$cur_key,2);
                 my ($key) = split('=',$cur_key,2);  
  $key = &unescape($key);  
                 delete($env{$key});                  delete($env{$key});
             } else {              } else {
                 print $fh $cur_key;                   print $fh $cur_key; 
Line 952  sub userenvironment { Line 947  sub userenvironment {
 sub studentphoto {  sub studentphoto {
     my ($udom,$unam,$ext) = @_;      my ($udom,$unam,$ext) = @_;
     my $home=&Apache::lonnet::homeserver($unam,$udom);      my $home=&Apache::lonnet::homeserver($unam,$udom);
     if (defined($env{'request.course.id'})) {      my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);
         if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {      my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;
             if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {      if ($ret ne 'ok') {
                 return(&retrievestudentphoto($udom,$unam,$ext));    return '/adm/lonKaputt/lonlogo_broken.gif';
             } else {  
                 my ($result,$perm_reqd)=  
     &Apache::lonnet::auto_photo_permission($unam,$udom);  
                 if ($result eq 'ok') {  
                     if (!($perm_reqd eq 'yes')) {  
                         return(&retrievestudentphoto($udom,$unam,$ext));  
                     }  
                 }  
             }  
         }  
     } else {  
         my ($result,$perm_reqd) =   
     &Apache::lonnet::auto_photo_permission($unam,$udom);  
         if ($result eq 'ok') {  
             if (!($perm_reqd eq 'yes')) {  
                 return(&retrievestudentphoto($udom,$unam,$ext));  
             }  
         }  
     }  
     return '/adm/lonKaputt/lonlogo_broken.gif';  
 }  
   
 sub retrievestudentphoto {  
     my ($udom,$unam,$ext,$type) = @_;  
     my $home=&Apache::lonnet::homeserver($unam,$udom);  
     my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);  
     if ($ret eq 'ok') {  
         my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";  
         if ($type eq 'thumbnail') {  
             $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";   
         }  
         my $tokenurl=&Apache::lonnet::tokenwrapper($url);  
         return $tokenurl;  
     } else {  
         if ($type eq 'thumbnail') {  
             return '/adm/lonKaputt/genericstudent_tn.gif';  
         } else {   
             return '/adm/lonKaputt/lonlogo_broken.gif';  
         }  
     }      }
       my $tokenurl=&Apache::lonnet::tokenwrapper($url);
       return $tokenurl;
 }  }
   
 # -------------------------------------------------------------------- New chat  # -------------------------------------------------------------------- New chat
Line 1322  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 3108  sub customaccess { Line 3073  sub customaccess {
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb)=@_;      my ($priv,$uri,$symb)=@_;
     my $ver_orguri=$uri;  
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 3209  sub allowed { Line 3173  sub allowed {
                 $thisallowed.=$1;                  $thisallowed.=$1;
             }              }
         } else {          } else {
             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};              my $refuri=$env{'httpref.'.$orguri};
             if ($refuri) {              if ($refuri) {
                 if ($refuri =~ m|^/adm/|) {                  if ($refuri =~ m|^/adm/|) {
                     $thisallowed='F';                      $thisallowed='F';
Line 3440  sub allowed { Line 3404  sub allowed {
    return 'F';     return 'F';
 }  }
   
 sub split_uri_for_cond {  
     my $uri=&deversion(&declutter(shift));  
     my @uriparts=split(/\//,$uri);  
     my $filename=pop(@uriparts);  
     my $pathname=join('/',@uriparts);  
     return ($pathname,$filename);  
 }  
 # --------------------------------------------------- Is a resource on the map?  # --------------------------------------------------- Is a resource on the map?
   
 sub is_on_map {  sub is_on_map {
     my ($pathname,$filename) = &split_uri_for_cond(shift);      my $uri=&deversion(&declutter(shift));
       my @uriparts=split(/\//,$uri);
       my $filename=$uriparts[$#uriparts];
       my $pathname=$uri;
       $pathname=~s|/\Q$filename\E$||;
       $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 3723  sub auto_create_password { Line 3686  sub auto_create_password {
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
 }  }
   
 sub auto_photo_permission {  
     my ($cnum,$cdom,$students) = @_;  
     my $homeserver = &homeserver($cnum,$cdom);  
     my ($outcome,$perm_reqd,$conditions) =   
  split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);  
     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {  
  return (undef,undef);  
     }  
     return ($outcome,$perm_reqd,$conditions);  
 }  
   
 sub auto_checkphotos {  
     my ($uname,$udom,$pid) = @_;  
     my $homeserver = &homeserver($uname,$udom);  
     my ($result,$resulttype);  
     my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.  
    &escape($uname).':'.&escape($pid),  
    $homeserver));  
     if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {  
  return (undef,undef);  
     }  
     if ($outcome) {  
         ($result,$resulttype) = split(/:/,$outcome);  
     }   
     return ($result,$resulttype);  
 }  
   
 sub auto_photochoice {  
     my ($cnum,$cdom) = @_;  
     my $homeserver = &homeserver($cnum,$cdom);  
     my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.  
        &escape($cdom),  
        $homeserver)));  
     if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {  
  return (undef,undef);  
     }  
     return ($update,$comment);  
 }  
   
 sub auto_photoupdate {  
     my ($affiliatesref,$dom,$cnum,$photo) = @_;  
     my $homeserver = &homeserver($cnum,$dom);  
     my $host=$hostname{$homeserver};  
     my $cmd = '';  
     my $maxtries = 1;  
     foreach (keys %{$affiliatesref}) {  
         $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';  
     }  
     $cmd =~ s/%%$//;  
     $cmd = &escape($cmd);  
     my $query = 'institutionalphotos';  
     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);  
     unless ($queryid=~/^\Q$host\E\_/) {  
         &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);  
         return 'error: '.$queryid;  
     }  
     my $reply = &get_query_reply($queryid);  
     my $tries = 1;  
     while (($reply=~/^timeout/) && ($tries < $maxtries)) {  
         $reply = &get_query_reply($queryid);  
         $tries ++;  
     }  
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {  
         &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);  
     } else {  
         my @responses = split(/:/,$reply);  
         my $outcome = shift(@responses);   
         foreach my $item (@responses) {  
             my ($key,$value) = split(/=/,$item);  
             $$photo{$key} = $value;  
         }  
         return $outcome;  
     }  
     return 'error';  
 }  
   
 sub auto_instcode_format {  sub auto_instcode_format {
     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;      my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
     my $courses = '';      my $courses = '';
Line 3850  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 4653  sub GetFileTimestamp { Line 4544  sub GetFileTimestamp {
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
 # gets the value of a specific preevaluated condition  
 #    stored in the string  $env{user.state.<cid>}  
 # or looks up a condition reference in the bighash and if if hasn't  
 # already been evaluated recurses into docondval to get the value of  
 # the condition, then memoizing it to   
 #   $env{user.state.<cid>.<condition>}  
 sub directcondval {  sub directcondval {
     my $number=shift;      my $number=shift;
     if (!defined($env{'user.state.'.$env{'request.course.id'}})) {      if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
  &Apache::lonuserstate::evalstate();   &Apache::lonuserstate::evalstate();
     }      }
     if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {  
  return $env{'user.state.'.$env{'request.course.id'}.".$number"};  
     } elsif ($number =~ /^_/) {  
  my $sub_condition;  
  if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',  
  &GDBM_READER(),0640)) {  
     $sub_condition=$bighash{'conditions'.$number};  
     untie(%bighash);  
  }  
  my $value = &docondval($sub_condition);  
  &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);  
  return $value;  
     }  
     if ($env{'user.state.'.$env{'request.course.id'}}) {      if ($env{'user.state.'.$env{'request.course.id'}}) {
        return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);         return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
     } else {      } else {
Line 4684  sub directcondval { Line 4556  sub directcondval {
     }      }
 }  }
   
 # get the collection of conditions for this resource  
 sub condval {  sub condval {
     my $condidx=shift;      my $condidx=shift;
       my $result=0;
     my $allpathcond='';      my $allpathcond='';
     foreach my $cond (split(/\|/,$condidx)) {      foreach (split(/\|/,$condidx)) {
  if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {         if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) {
     $allpathcond.=     $allpathcond.=
  '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';                 '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|';
  }         }
     }      }
     $allpathcond=~s/\|$//;      $allpathcond=~s/\|$//;
     return &docondval($allpathcond);      if ($env{'request.course.id'}) {
 }         if ($allpathcond) {
             my $operand='|';
 #evaluates an expression of conditions    my @stack;
 sub docondval {             foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
     my ($allpathcond) = @_;                if ($_ eq '(') {
     my $result=0;                   push @stack,($operand,$result)
     if ($env{'request.course.id'}                } elsif ($_ eq ')') {
  && defined($allpathcond)) {                    my $before=pop @stack;
  my $operand='|';    if (pop @stack eq '&') {
  my @stack;        $result=$result>$before?$before:$result;
  foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {                    } else {
     if ($chunk eq '(') {                        $result=$result>$before?$result:$before;
  push @stack,($operand,$result);                    }
     } elsif ($chunk eq ')') {                } elsif (($_ eq '&') || ($_ eq '|')) {
  my $before=pop @stack;                    $operand=$_;
  if (pop @stack eq '&') {                } else {
     $result=$result>$before?$before:$result;                    my $new=directcondval($_);
  } else {                    if ($operand eq '&') {
     $result=$result>$before?$result:$before;                       $result=$result>$new?$new:$result;
  }                    } else {
     } elsif (($chunk eq '&') || ($chunk eq '|')) {                       $result=$result>$new?$result:$new;
  $operand=$chunk;                    }
     } else {                }
  my $new=directcondval($chunk);            }
  if ($operand eq '&') {         }
     $result=$result>$new?$new:$result;  
  } else {  
     $result=$result>$new?$result:$new;  
  }  
     }  
  }  
     }      }
     return $result;      return $result;
 }  }
Line 4958  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 4978  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 4999  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 5084  sub EXT { Line 4974  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 5311  sub metadata { Line 5227  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 5407  sub get_slot { Line 5323  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 6157  sub filelocation { Line 6066  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 6201  sub hreflocation { Line 6105  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 6281  sub clutter { Line 6182  sub clutter {
      && $thisfn!~/\.(sequence|page)$/) {       && $thisfn!~/\.(sequence|page)$/) {
  $thisfn='/adm/coursedocs/showdoc'.$thisfn;   $thisfn='/adm/coursedocs/showdoc'.$thisfn;
     } else {      } else {
  #&logthis("Got a blank emb style");   &logthis("Got a blank emb style");
     }      }
  }   }
     }      }
Line 6428  BEGIN { Line 6329  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.20  
changed lines
  Added in v.1.698

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