version 1.683.2.12, 2006/01/13 19:22:29
|
version 1.683.2.22, 2006/06/05 20:10:20
|
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 324 sub appenv {
|
Line 326 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 336 sub appenv {
|
Line 340 sub appenv {
|
} |
} |
my $newname; |
my $newname; |
foreach $newname (keys %newenv) { |
foreach $newname (keys %newenv) { |
print $fh "$newname=$newenv{$newname}\n"; |
print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; |
} |
} |
close($fh); |
close($fh); |
} |
} |
Line 348 sub appenv {
|
Line 352 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 380 sub delenv {
|
Line 383 sub delenv {
|
close($fh); |
close($fh); |
return 'error: '.$!; |
return 'error: '.$!; |
} |
} |
foreach (@oldenv) { |
foreach my $cur_key (@oldenv) { |
if ($_=~/^$delthis/) { |
my $unescaped_cur_key = &unescape($cur_key); |
my ($key,undef) = split('=',$_,2); |
if ($unescaped_cur_key=~/^$delthis/) { |
|
my ($key) = split('=',$cur_key,2); |
|
$key = &unescape($key); |
delete($env{$key}); |
delete($env{$key}); |
} else { |
} else { |
print $fh $_; |
print $fh $cur_key; |
} |
} |
} |
} |
close($fh); |
close($fh); |
Line 947 sub userenvironment {
|
Line 952 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); |
my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home); |
if (defined($env{'request.course.id'})) { |
my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext; |
if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) { |
if ($ret ne 'ok') { |
if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) { |
return '/adm/lonKaputt/lonlogo_broken.gif'; |
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 |
# -------------------------------------------------------------------- New chat |
Line 3066 sub customaccess {
|
Line 3108 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 3166 sub allowed {
|
Line 3209 sub allowed {
|
$thisallowed.=$1; |
$thisallowed.=$1; |
} |
} |
} else { |
} else { |
my $refuri=$env{'httpref.'.$orguri}; |
my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri}; |
if ($refuri) { |
if ($refuri) { |
if ($refuri =~ m|^/adm/|) { |
if ($refuri =~ m|^/adm/|) { |
$thisallowed='F'; |
$thisallowed='F'; |
Line 3397 sub allowed {
|
Line 3440 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 $uri=&deversion(&declutter(shift)); |
my ($pathname,$filename) = &split_uri_for_cond(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 3679 sub auto_create_password {
|
Line 3723 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 4533 sub GetFileTimestamp {
|
Line 4653 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 4545 sub directcondval {
|
Line 4684 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 (split(/\|/,$condidx)) { |
foreach my $cond (split(/\|/,$condidx)) { |
if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) { |
if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) { |
$allpathcond.= |
$allpathcond.= |
'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|'; |
'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|'; |
} |
} |
} |
} |
$allpathcond=~s/\|$//; |
$allpathcond=~s/\|$//; |
if ($env{'request.course.id'}) { |
return &docondval($allpathcond); |
if ($allpathcond) { |
} |
my $operand='|'; |
|
my @stack; |
#evaluates an expression of conditions |
foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) { |
sub docondval { |
if ($_ eq '(') { |
my ($allpathcond) = @_; |
push @stack,($operand,$result) |
my $result=0; |
} elsif ($_ eq ')') { |
if ($env{'request.course.id'} |
my $before=pop @stack; |
&& defined($allpathcond)) { |
if (pop @stack eq '&') { |
my $operand='|'; |
$result=$result>$before?$before:$result; |
my @stack; |
} else { |
foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) { |
$result=$result>$before?$result:$before; |
if ($chunk eq '(') { |
} |
push @stack,($operand,$result); |
} elsif (($_ eq '&') || ($_ eq '|')) { |
} elsif ($chunk eq ')') { |
$operand=$_; |
my $before=pop @stack; |
} else { |
if (pop @stack eq '&') { |
my $new=directcondval($_); |
$result=$result>$before?$before:$result; |
if ($operand eq '&') { |
} else { |
$result=$result>$new?$new:$result; |
$result=$result>$before?$result:$before; |
} else { |
} |
$result=$result>$new?$result:$new; |
} 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; |
return $result; |
} |
} |
Line 4732 sub EXT {
|
Line 4877 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()) ) { |
return $Apache::lonhomework::history{$qualifierrest}; |
# if we are in the middle of processing the resource the |
|
# 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 4825 sub EXT {
|
Line 4976 sub EXT {
|
|
|
# ----------------------------------------------------- Cascading lookup scheme |
# ----------------------------------------------------- Cascading lookup scheme |
my $symbp=$symbparm; |
my $symbp=$symbparm; |
my $mapp=(&decode_symb($symbp))[0]; |
my $mapp=&deversion((&decode_symb($symbp))[0]); |
|
|
my $symbparm=$symbp.'.'.$spacequalifierrest; |
my $symbparm=$symbp.'.'.$spacequalifierrest; |
my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
Line 5262 sub get_slot {
|
Line 5413 sub get_slot {
|
$cdom=$env{'course.'.$courseid.'.domain'}; |
$cdom=$env{'course.'.$courseid.'.domain'}; |
$cnum=$env{'course.'.$courseid.'.num'}; |
$cnum=$env{'course.'.$courseid.'.num'}; |
} |
} |
my %slotinfo=&get('slots',[$which],$cdom,$cnum); |
my $key=join("\0",'slots',$cdom,$cnum,$which); |
&Apache::lonhomework::showhash(%slotinfo); |
my %slotinfo; |
my ($tmp)=keys(%slotinfo); |
if (exists($remembered{$key})) { |
if ($tmp=~/^error:/) { return (); } |
$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') { |
if (ref($slotinfo{$which}) eq 'HASH') { |
return %{$slotinfo{$which}}; |
return %{$slotinfo{$which}}; |
} |
} |