[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.22 and 1.684

version 1.683.2.22, 2006/06/05 20:10:20 version 1.684, 2005/11/22 02:24:55
Line 40  qw(%perlvar %hostname %badServerCache %i Line 40  qw(%perlvar %hostname %badServerCache %i
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
    %domaindescription %domain_auth_def %domain_auth_arg_def      %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit
    $tmpdir $_64bit %env);     %env);
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
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]);
  $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 325  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]);
     $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 383  sub delenv { Line 380  sub delenv {
     close($fh);      close($fh);
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach my $cur_key (@oldenv) {   foreach (@oldenv) {
     my $unescaped_cur_key = &unescape($cur_key);      if ($_=~/^$delthis/) { 
     if ($unescaped_cur_key=~/^$delthis/) {                   my ($key,undef) = split('=',$_);
                 my ($key) = split('=',$cur_key,2);  
  $key = &unescape($key);  
                 delete($env{$key});                  delete($env{$key});
             } else {              } else {
                 print $fh $cur_key;                   print $fh $_; 
             }              }
  }   }
  close($fh);   close($fh);
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 1895  sub courseiddump { Line 1853  sub courseiddump {
 # ---------------------------------------------------------- DC e-mail  # ---------------------------------------------------------- DC e-mail
   
 sub dcmailput {  sub dcmailput {
     my ($domain,$msgid,$message,$server)=@_;      my ($domain,$msgid,$contents,$server)=@_;
     my $status = &Apache::lonnet::critical(      my $status = &Apache::lonnet::critical(
        'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.         'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
        &Apache::lonnet::escape($message),$server);         &Apache::lonnet::escape($$contents{$server}),$server);
     return $status;      return $status;
 }  }
   
 sub dcmaildump {  sub dcmaildump {
     my ($dom,$startdate,$enddate,$senders) = @_;      my ($dom,$startdate,$enddate,$senders) = @_;
     my %returnhash=();      my %returnhash=(); 
     if (exists($domain_primary{$dom})) {      foreach my $tryserver (keys(%libserv)) {
         my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.          if ($hostdom{$tryserver} eq $dom) {
                                                          &escape($enddate).':';              %{$returnhash{$tryserver}}=();
  my @esc_senders=map { &escape($_)} @$senders;      my $cmd='dcmaildump:'.$dom.':'.
  $cmd.=&escape(join('&',@esc_senders));   &escape($startdate).':'.&escape($enddate).':';
  foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {      my @esc_senders=map { &escape($_)} @$senders;
             my ($key,$value) = split(/\=/,$_);      $cmd.=&escape(join('&',@esc_senders));
             if (($key) && ($value)) {      foreach (split(/\&/,&reply($cmd,$tryserver))) {
                 $returnhash{&unescape($key)} = &unescape($value);                  my ($key,$value) = split(/\=/,$_);
                   if (($key) && ($value)) {
                       $returnhash{$tryserver}{&unescape($key)} = &unescape($value);
                   }
             }              }
         }          }
     }      }
Line 3052  sub tmpput { Line 3013  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 3063  sub tmpget { Line 3023  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 3108  sub customaccess { Line 3061  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 3161  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 3389  sub allowed { Line 3341  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 3413  sub allowed { Line 3361  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 3440  sub allowed { Line 3386  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\///;    
     #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 3667  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 3718  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 4525  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 4537  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 4877  sub EXT { Line 4724  sub EXT {
     if ( (defined($Apache::lonhomework::parsing_a_problem)      if ( (defined($Apache::lonhomework::parsing_a_problem)
   || defined($Apache::lonhomework::parsing_a_task))    || defined($Apache::lonhomework::parsing_a_task))
  &&   &&
  ($symbparm eq &symbread()) ) {   ($symbparm eq &symbread()) ) {
  # if we are in the middle of processing the resource the   return $Apache::lonhomework::history{$qualifierrest};
  # get the value we are planning on committing  
                 if (defined($Apache::lonhomework::results{$qualifierrest})) {  
                     return $Apache::lonhomework::results{$qualifierrest};  
                 } else {  
                     return $Apache::lonhomework::history{$qualifierrest};  
                 }  
     } else {      } else {
  my %restored;   my %restored;
  if ($publicuser || $env{'request.state'} eq 'construct') {   if ($publicuser || $env{'request.state'} eq 'construct') {
Line 4964  sub EXT { Line 4805  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 4976  sub EXT { Line 4818  sub EXT {
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=&deversion((&decode_symb($symbp))[0]);      my $mapp=(&decode_symb($symbp))[0];
   
     my $symbparm=$symbp.'.'.$spacequalifierrest;      my $symbparm=$symbp.'.'.$spacequalifierrest;
     my $mapparm=$mapp.'___(all).'.$spacequalifierrest;      my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
Line 4984  sub EXT { Line 4826  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 5009  sub EXT { Line 4866  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 5081  sub EXT { Line 4947  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 5317  sub metadata { Line 5178  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 5413  sub get_slot { Line 5274  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 5457  sub symbverify { Line 5311  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 5512  sub symbclean { Line 5365  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 5589  sub symbread { Line 5441  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 6163  sub filelocation { Line 6012  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 6207  sub hreflocation { Line 6051  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 6253  sub declutter { Line 6094  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 6267  sub clutter { Line 6106  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 6399  BEGIN { Line 6214  BEGIN {
 #           next if /^\#/;  #           next if /^\#/;
            chomp;             chomp;
            my ($domain, $domain_description, $def_auth, $def_auth_arg,             my ($domain, $domain_description, $def_auth, $def_auth_arg,
        $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);         $def_lang, $city, $longi, $lati) = split(/:/,$_);
    $domain_auth_def{$domain}=$def_auth;     $domain_auth_def{$domain}=$def_auth;
            $domain_auth_arg_def{$domain}=$def_auth_arg;             $domain_auth_arg_def{$domain}=$def_auth_arg;
    $domaindescription{$domain}=$domain_description;     $domaindescription{$domain}=$domain_description;
Line 6407  BEGIN { Line 6222  BEGIN {
    $domain_city{$domain}=$city;     $domain_city{$domain}=$city;
    $domain_longi{$domain}=$longi;     $domain_longi{$domain}=$longi;
    $domain_lati{$domain}=$lati;     $domain_lati{$domain}=$lati;
            $domain_primary{$domain}=$primary;  
   
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");   #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );  #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
Line 6434  BEGIN { Line 6248  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.22  
changed lines
  Added in v.1.684

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