--- loncom/lonnet/perl/lonnet.pm 2006/01/11 20:26:45 1.683.2.10
+++ loncom/lonnet/perl/lonnet.pm 2006/04/06 19:19:11 1.683.2.20
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.683.2.10 2006/01/11 20:26:45 albertel Exp $
+# $Id: lonnet.pm,v 1.683.2.20 2006/04/06 19:19:11 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -272,6 +272,8 @@ sub transfer_profile_to_env {
for ($envi=0;$envi<=$#profile;$envi++) {
chomp($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) {
@@ -324,6 +326,8 @@ sub appenv {
chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {
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('=',$_,2);
+ 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,16 +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\///;
- $pathname=~s/^adm\/coursedocs\/showdoc\///;
+ 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\|]+)\&/);
@@ -3679,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 = '';
@@ -4533,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 {
@@ -4545,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;
}
@@ -5166,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};
@@ -5262,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}};
}
@@ -6005,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:;
@@ -6044,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--;
@@ -6121,7 +6281,7 @@ sub clutter {
&& $thisfn!~/\.(sequence|page)$/) {
$thisfn='/adm/coursedocs/showdoc'.$thisfn;
} else {
- &logthis("Got a blank emb style");
+ #&logthis("Got a blank emb style");
}
}
}