--- loncom/lonnet/perl/lonnet.pm	2006/01/05 19:39:52	1.683.2.5
+++ loncom/lonnet/perl/lonnet.pm	2006/05/15 23:42:52	1.683.2.21
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.683.2.5 2006/01/05 19:39:52 albertel Exp $
+# $Id: lonnet.pm,v 1.683.2.21 2006/05/15 23:42:52 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -271,7 +271,9 @@ sub transfer_profile_to_env {
     my %Remove;
     for ($envi=0;$envi<=$#profile;$envi++) {
 	chomp($profile[$envi]);
-	my ($envname,$envvalue)=split(/=/,$profile[$envi]);
+	my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
+	$envname=&unescape($envname);
+	$envvalue=&unescape($envvalue);
 	$env{$envname} = $envvalue;
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {
@@ -323,7 +325,9 @@ sub appenv {
     for (my $i=0; $i<=$#oldenv; $i++) {
         chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {
-	    my ($name,$value)=split(/=/,$oldenv[$i]);
+	    my ($name,$value)=split(/=/,$oldenv[$i],2);
+	    $name=&unescape($name);
+	    $value=&unescape($value);
 	    unless (defined($newenv{$name})) {
 		$newenv{$name}=$value;
 	    }
@@ -336,7 +340,7 @@ sub appenv {
 	}
 	my $newname;
 	foreach $newname (keys %newenv) {
-	    print $fh "$newname=$newenv{$newname}\n";
+	    print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";
 	}
 	close($fh);
     }
@@ -348,7 +352,6 @@ sub appenv {
 
 sub delenv {
     my $delthis=shift;
-    my %newenv=();
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);
@@ -380,12 +383,14 @@ sub delenv {
 	    close($fh);
 	    return 'error: '.$!;
 	}
-	foreach (@oldenv) {
-	    if ($_=~/^$delthis/) { 
-                my ($key,undef) = split('=',$_);
+	foreach my $cur_key (@oldenv) {
+	    my $unescaped_cur_key = &unescape($cur_key);
+	    if ($unescaped_cur_key=~/^$delthis/) { 
+                my ($key) = split('=',$cur_key,2);
+		$key = &unescape($key);
                 delete($env{$key});
             } else {
-                print $fh $_; 
+                print $fh $cur_key; 
             }
 	}
 	close($fh);
@@ -947,13 +952,50 @@ sub userenvironment {
 sub studentphoto {
     my ($udom,$unam,$ext) = @_;
     my $home=&Apache::lonnet::homeserver($unam,$udom);
-    my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);
-    my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;
-    if ($ret ne 'ok') {
-	return '/adm/lonKaputt/lonlogo_broken.gif';
+    if (defined($env{'request.course.id'})) {
+        if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
+            if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
+                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));
+                    }
+                }
+            }
+        }
+    } 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
@@ -3066,6 +3108,7 @@ sub customaccess {
 
 sub allowed {
     my ($priv,$uri,$symb)=@_;
+    my $ver_orguri=$uri;
     $uri=&deversion($uri);
     my $orguri=$uri;
     $uri=&declutter($uri);
@@ -3166,7 +3209,7 @@ sub allowed {
                 $thisallowed.=$1;
             }
         } else {
-            my $refuri=$env{'httpref.'.$orguri};
+            my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
             if ($refuri) {
                 if ($refuri =~ m|^/adm/|) {
                     $thisallowed='F';
@@ -3397,15 +3440,17 @@ sub allowed {
    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?
 
 sub is_on_map {
-    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\///;    
+    my ($pathname,$filename) = &split_uri_for_cond(shift);
     #Trying to find the conditional for the file
     my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
 	       /\&\Q$filename\E\:([\d\|]+)\&/);
@@ -3678,6 +3723,82 @@ sub auto_create_password {
     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 {
     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
     my $courses = '';
@@ -4532,11 +4653,30 @@ sub GetFileTimestamp {
 
 # -------------------------------------------------------- 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 {
     my $number=shift;
     if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
 	&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'}}) {
        return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
     } else {
@@ -4544,43 +4684,49 @@ sub directcondval {
     }
 }
 
+# get the collection of conditions for this resource
 sub condval {
     my $condidx=shift;
-    my $result=0;
     my $allpathcond='';
-    foreach (split(/\|/,$condidx)) {
-       if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) {
-	   $allpathcond.=
-               '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|';
-       }
+    foreach my $cond (split(/\|/,$condidx)) {
+	if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
+	    $allpathcond.=
+		'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
+	}
     }
     $allpathcond=~s/\|$//;
-    if ($env{'request.course.id'}) {
-       if ($allpathcond) {
-          my $operand='|';
-	  my @stack;
-           foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
-              if ($_ eq '(') {
-                 push @stack,($operand,$result)
-              } elsif ($_ eq ')') {
-                  my $before=pop @stack;
-		  if (pop @stack eq '&') {
-		      $result=$result>$before?$before:$result;
-                  } else {
-                      $result=$result>$before?$result:$before;
-                  }
-              } elsif (($_ eq '&') || ($_ eq '|')) {
-                  $operand=$_;
-              } else {
-                  my $new=directcondval($_);
-                  if ($operand eq '&') {
-                     $result=$result>$new?$new:$result;
-                  } else {
-                     $result=$result>$new?$result:$new;
-                  }
-              }
-          }
-       }
+    return &docondval($allpathcond);
+}
+
+#evaluates an expression of conditions
+sub docondval {
+    my ($allpathcond) = @_;
+    my $result=0;
+    if ($env{'request.course.id'}
+	&& defined($allpathcond)) {
+	my $operand='|';
+	my @stack;
+	foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
+	    if ($chunk eq '(') {
+		push @stack,($operand,$result);
+	    } elsif ($chunk eq ')') {
+		my $before=pop @stack;
+		if (pop @stack eq '&') {
+		    $result=$result>$before?$before:$result;
+		} else {
+		    $result=$result>$before?$result:$before;
+		}
+	    } elsif (($chunk eq '&') || ($chunk eq '|')) {
+		$operand=$chunk;
+	    } else {
+		my $new=directcondval($chunk);
+		if ($operand eq '&') {
+		    $result=$result>$new?$new:$result;
+		} else {
+		    $result=$result>$new?$result:$new;
+		}
+	    }
+	}
     }
     return $result;
 }
@@ -4824,7 +4970,7 @@ sub EXT {
 
 # ----------------------------------------------------- Cascading lookup scheme
 	    my $symbp=$symbparm;
-	    my $mapp=(&decode_symb($symbp))[0];
+	    my $mapp=&deversion((&decode_symb($symbp))[0]);
 
 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
@@ -4929,6 +5075,11 @@ sub EXT {
 	if ($space eq 'time') {
 	    return time;
         }
+    } elsif ($realm eq 'server') {
+# ----------------------------------------------------------------- system.time
+	if ($space eq 'name') {
+	    return $ENV{'SERVER_NAME'};
+        }
     }
     return '';
 }
@@ -5160,7 +5311,7 @@ sub metadata {
 	$metaentry{':keys'}=join(',',keys %metathesekeys);
 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
-	&do_cache_new('meta',$uri,\%metaentry,60*60*24);
+	&do_cache_new('meta',$uri,\%metaentry,60*60);
 # this is the end of "was not already recently cached
     }
     return $metaentry{':'.$what};
@@ -5256,10 +5407,17 @@ sub get_slot {
 	$cdom=$env{'course.'.$courseid.'.domain'};
 	$cnum=$env{'course.'.$courseid.'.num'};
     }
-    my %slotinfo=&get('slots',[$which],$cdom,$cnum);
-    &Apache::lonhomework::showhash(%slotinfo);
-    my ($tmp)=keys(%slotinfo);
-    if ($tmp=~/^error:/) { return (); }
+    my $key=join("\0",'slots',$cdom,$cnum,$which);
+    my %slotinfo;
+    if (exists($remembered{$key})) {
+	$slotinfo{$which} = $remembered{$key};
+    } 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') {
 	return %{$slotinfo{$which}};
     }
@@ -5293,6 +5451,7 @@ sub symbverify {
     my $thisfn=$thisurl;
 # wrapper not part of symbs
     $thisfn=~s/^\/adm\/wrapper//;
+    $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;
     $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
@@ -5347,6 +5506,7 @@ sub symbclean {
 # remove wrapper
 
     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
+    $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
     return $symb;
 }
 
@@ -5997,6 +6157,11 @@ sub filelocation {
     my ($dir,$file) = @_;
     my $location;
     $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
         $location = $file;
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
@@ -6036,6 +6201,9 @@ sub hreflocation {
     my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
 	$file=filelocation($dir,$file);
+    } elsif ($file=~m-^/adm/-) {
+	$file=~s-^/adm/wrapper/-/-;
+	$file=~s-^/adm/coursedocs/showdoc/-/-;
     }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
 	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
@@ -6079,6 +6247,8 @@ sub declutter {
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $thisfn=~s/^\///;
+    $thisfn=~s|^adm/wrapper/||;
+    $thisfn=~s|^adm/coursedocs/showdoc/||;
     $thisfn=~s/^res\///;
     $thisfn=~s/\?.+$//;
     return $thisfn;
@@ -6091,6 +6261,30 @@ sub clutter {
     unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { 
        $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;
 }