--- loncom/lonnet/perl/lonnet.pm 2005/04/05 20:43:27 1.619 +++ loncom/lonnet/perl/lonnet.pm 2005/07/26 13:30:34 1.648 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.619 2005/04/05 20:43:27 albertel Exp $ +# $Id: lonnet.pm,v 1.648 2005/07/26 13:30:34 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -47,6 +47,7 @@ use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); use HTML::LCParser; +use HTML::Parser; use Fcntl qw(:flock); use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); @@ -254,20 +255,6 @@ sub critical { return $answer; } -# -# -------------- Remove all key from the env that start witha lowercase letter -# (Which is always a lon-capa value) - -sub cleanenv { -# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; } -# unless (&Apache::exists_config_define("MODPERL2")) { return; } - foreach my $key (keys(%ENV)) { - if ($key =~ /^[a-z]/) { - delete($ENV{$key}); - } - } -} - # ------------------------------------------- Transfer profile into environment sub transfer_profile_to_env { @@ -284,7 +271,6 @@ sub transfer_profile_to_env { for ($envi=0;$envi<=$#profile;$envi++) { chomp($profile[$envi]); my ($envname,$envvalue)=split(/=/,$profile[$envi]); - $ENV{$envname} = $envvalue; $env{$envname} = $envvalue; if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { @@ -292,7 +278,6 @@ sub transfer_profile_to_env { } } } - $ENV{'user.environment'} = "$lonidsdir/$handle.id"; $env{'user.environment'} = "$lonidsdir/$handle.id"; foreach my $expired_key (keys(%Remove)) { &delenv($expired_key); @@ -310,13 +295,12 @@ sub appenv { .''); delete($newenv{$_}); } else { - $ENV{$_}=$newenv{$_}; $env{$_}=$newenv{$_}; } } my $lockfh; - unless (open($lockfh,"$ENV{'user.environment'}")) { + unless (open($lockfh,"$env{'user.environment'}")) { return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { @@ -329,7 +313,7 @@ sub appenv { my @oldenv; { my $fh; - unless (open($fh,"$ENV{'user.environment'}")) { + unless (open($fh,"$env{'user.environment'}")) { return 'error: '.$!; } @oldenv=<$fh>; @@ -346,7 +330,7 @@ sub appenv { } { my $fh; - unless (open($fh,">$ENV{'user.environment'}")) { + unless (open($fh,">$env{'user.environment'}")) { return 'error'; } my $newname; @@ -372,7 +356,7 @@ sub delenv { my @oldenv; { my $fh; - unless (open($fh,"$ENV{'user.environment'}")) { + unless (open($fh,"$env{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_SH)) { @@ -386,7 +370,7 @@ sub delenv { } { my $fh; - unless (open($fh,">$ENV{'user.environment'}")) { + unless (open($fh,">$env{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_EX)) { @@ -398,7 +382,6 @@ sub delenv { foreach (@oldenv) { if ($_=~/^$delthis/) { my ($key,undef) = split('=',$_); - delete($ENV{$key}); delete($env{$key}); } else { print $fh $_; @@ -662,15 +645,15 @@ sub assign_access_key { # my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_; $kdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom)); $knum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum)); $cdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); - $udom=$ENV{'user.name'} unless (defined($udom)); - $uname=$ENV{'user.domain'} unless (defined($uname)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$env{'user.name'} unless (defined($udom)); + $uname=$env{'user.domain'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$kdom,$knum); if (($existing{$ckey}=~/^\#(.*)$/) || # - new key ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { @@ -712,9 +695,9 @@ sub comment_access_key { # my ($ckey,$cdom,$cnum,$logentry)=@_; $cdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); if ($existing{$ckey}) { $existing{$ckey}.='; '.$logentry; @@ -736,9 +719,9 @@ sub comment_access_key { sub generate_access_keys { my ($number,$cdom,$cnum,$logentry)=@_; $cdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); unless (&allowed('mky',$cdom)) { return 0; } unless (($cdom) && ($cnum)) { return 0; } if ($number>10000) { return 0; } @@ -757,14 +740,14 @@ sub generate_access_keys { } else { if (&put('accesskeys', { $newkey => '# generated '.localtime(). - ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. + ' by '.$env{'user.name'}.'@'.$env{'user.domain'}. '; '.$logentry }, $cdom,$cnum) eq 'ok') { $total++; } } } - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); return $total; } @@ -774,11 +757,11 @@ sub generate_access_keys { sub validate_access_key { my ($ckey,$cdom,$cnum,$udom,$uname)=@_; $cdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); - $udom=$ENV{'user.domain'} unless (defined($udom)); - $uname=$ENV{'user.name'} unless (defined($uname)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$env{'user.domain'} unless (defined($udom)); + $uname=$env{'user.name'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); } @@ -845,7 +828,11 @@ sub getsection { } sub save_cache { + my ($r)=@_; + if (! $r->is_initial_req()) { return DECLINED; } &purge_remembered(); + undef(%env); + return OK; } my $to_remember=-1; @@ -892,6 +879,9 @@ sub do_cache_new { if (!defined($setvalue)) { $setvalue='__undef__'; } + if (!defined($time) ) { + $time=600; + } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } $memcache->set($id,$setvalue,$time); # need to make a copy of $value @@ -958,11 +948,11 @@ sub studentphoto { sub chatsend { my ($newentry,$anon)=@_; - my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; - my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; - my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'}; + my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'}; + my $chome=$env{'course.'.$env{'request.course.id'}.'.home'}; &reply('chatsend:'.$cdom.':'.$cnum.':'. - &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. + &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'. &escape($newentry)),$chome); } @@ -1142,8 +1132,11 @@ sub allowuploaded { } # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course -# input: action, courseID, current domain, home server for course, intended -# path to file, source of file. +# input: action, courseID, current domain, intended +# path to file, source of file, instruction to parse file for objects, +# ref to hash for embedded objects, +# ref to hash for codebase of java objects. +# # output: url to file (if action was uploaddoc), # ok if successful, or diagnostic message otherwise (if action was propagate or copy) # @@ -1162,34 +1155,26 @@ sub allowuploaded { # course's home server. # # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file -# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to +# will be retrived from $env{form.uploaddoc} (from DOCS interface) to # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file # and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file # in course's home server. - +# sub process_coursefile { - my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_; + my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_; my $fetchresult; + my $home=&homeserver($docuname,$docudom); if ($action eq 'propagate') { - $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file - ,$docuhome); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $home); } else { my $fetchresult = ''; my $fpath = ''; my $fname = $file; ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); $fpath=$docudom.'/'.$docuname.'/'.$fpath; - my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; - unless ($fpath eq '') { - my @parts=split('/',$fpath); - foreach my $part (@parts) { - $filepath.= '/'.$part; - if ((-e $filepath)!=1) { - mkdir($filepath,0777); - } - } - } + my $filepath = &build_filepath($fpath); if ($action eq 'copy') { if ($source eq '') { $fetchresult = 'no source file'; @@ -1198,30 +1183,75 @@ sub process_coursefile { my $destination = $filepath.'/'.$fname; rename($source,$destination); $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, - $docuhome); + $home); } } elsif ($action eq 'uploaddoc') { open(my $fh,'>'.$filepath.'/'.$fname); - print $fh $ENV{'form.'.$source}; + print $fh $env{'form.'.$source}; close($fh); + if ($parser eq 'parse') { + my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase); + unless ($parse_result eq 'ok') { + &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); + } + } $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, - $docuhome); + $home); if ($fetchresult eq 'ok') { return '/uploaded/'.$fpath.'/'.$fname; } else { &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. - ' to host '.$docuhome.': '.$fetchresult); + ' to host '.$home.': '.$fetchresult); return '/adm/notfound.html'; } } } unless ( $fetchresult eq 'ok') { &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. - ' to host '.$docuhome.': '.$fetchresult); + ' to host '.$home.': '.$fetchresult); } return $fetchresult; } +sub build_filepath { + my ($fpath) = @_; + my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; + unless ($fpath eq '') { + my @parts=split('/',$fpath); + foreach my $part (@parts) { + $filepath.= '/'.$part; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } + } + return $filepath; +} + +sub store_edited_file { + my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_; + my $file = $primary_url; + $file =~ s#^/uploaded/$docudom/$docuname/##; + my $fpath = ''; + my $fname = $file; + ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); + $fpath=$docudom.'/'.$docuname.'/'.$fpath; + my $filepath = &build_filepath($fpath); + open(my $fh,'>'.$filepath.'/'.$fname); + print $fh $content; + close($fh); + my $home=&homeserver($docuname,$docudom); + $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $home); + if ($$fetchresult eq 'ok') { + return '/uploaded/'.$fpath.'/'.$fname; + } else { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$home.': '.$$fetchresult); + return '/adm/notfound.html'; + } +} + sub clean_filename { my ($fname)=@_; # Replace Windows backslashes by forward slashes @@ -1244,13 +1274,13 @@ sub clean_filename { sub userfileupload { - my ($formname,$coursedoc,$subdir)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_; if (!defined($subdir)) { $subdir='unknown'; } - my $fname=$ENV{'form.'.$formname.'.filename'}; + my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } - chop($ENV{'form.'.$formname}); + chop($env{'form.'.$formname}); if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently my $now = time; my $filepath = 'tmp/helprequests/'.$now; @@ -1263,35 +1293,35 @@ sub userfileupload { } } open(my $fh,'>'.$fullpath.'/'.$fname); - print $fh $ENV{'form.'.$formname}; + print $fh $env{'form.'.$formname}; close($fh); return $fullpath.'/'.$fname; } # Create the directory if not present - my $docuname=''; - my $docudom=''; - my $docuhome=''; $fname="$subdir/$fname"; if ($coursedoc) { - $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; - $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; - $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; - if ($ENV{'form.folder'} =~ m/^default/) { - return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; + my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; + if ($env{'form.folder'} =~ m/^(default|supplemental)/) { + return &finishuserfileupload($docuname,$docudom, + $formname,$fname,$parser,$allfiles, + $codebase); } else { - $fname=$ENV{'form.folder'}.'/'.$fname; - return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname); + $fname=$env{'form.folder'}.'/'.$fname; + return &process_coursefile('uploaddoc',$docuname,$docudom, + $fname,$formname,$parser, + $allfiles,$codebase); } } else { - $docuname=$ENV{'user.name'}; - $docudom=$ENV{'user.domain'}; - $docuhome=$ENV{'user.home'}; - return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + my $docuname=$env{'user.name'}; + my $docudom=$env{'user.domain'}; + return &finishuserfileupload($docuname,$docudom,$formname, + $fname,$parser,$allfiles,$codebase); } } sub finishuserfileupload { - my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; + my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; my ($fnamepath,$file); @@ -1311,11 +1341,20 @@ sub finishuserfileupload { # Save the file { open(FH,'>'.$filepath.'/'.$file); - print FH $ENV{'form.'.$formname}; + print FH $env{'form.'.$formname}; close(FH); } + if ($parser eq 'parse') { + my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, + $codebase); + unless ($parse_result eq 'ok') { + &logthis('Failed to parse '.$filepath.$file. + ' for embedded media: '.$parse_result); + } + } # Notify homeserver to grep it # + my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { # @@ -1328,6 +1367,114 @@ sub finishuserfileupload { } } +sub extract_embedded_items { + my ($filepath,$file,$allfiles,$codebase,$content) = @_; + my @state = (); + my %javafiles = ( + codebase => '', + code => '', + archive => '' + ); + my %mediafiles = ( + src => '', + movie => '', + ); + my $p; + if ($content) { + $p = HTML::LCParser->new($content); + } else { + $p = HTML::LCParser->new($filepath.'/'.$file); + } + while (my $t=$p->get_token()) { + if ($t->[0] eq 'S') { + my ($tagname, $attr) = ($t->[1],$t->[2]); + push (@state, $tagname); + if (lc($tagname) eq 'allow') { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + if (lc($tagname) eq 'img') { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + if (lc($tagname) eq 'script') { + if ($attr->{'archive'} =~ /\.jar$/i) { + &add_filetype($allfiles,$attr->{'archive'},'archive'); + } else { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + } + if (lc($tagname) eq 'link') { + if (lc($attr->{'rel'}) eq 'stylesheet') { + &add_filetype($allfiles,$attr->{'href'},'href'); + } + } + if (lc($tagname) eq 'object' || + (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) { + foreach my $item (keys(%javafiles)) { + $javafiles{$item} = ''; + } + } + if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { + my $name = lc($attr->{'name'}); + foreach my $item (keys(%javafiles)) { + if ($name eq $item) { + $javafiles{$item} = $attr->{'value'}; + last; + } + } + foreach my $item (keys(%mediafiles)) { + if ($name eq $item) { + &add_filetype($allfiles, $attr->{'value'}, 'value'); + last; + } + } + } + if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { + foreach my $item (keys(%javafiles)) { + if ($attr->{$item}) { + $javafiles{$item} = $attr->{$item}; + last; + } + } + foreach my $item (keys(%mediafiles)) { + if ($attr->{$item}) { + &add_filetype($allfiles,$attr->{$item},$item); + last; + } + } + } + } elsif ($t->[0] eq 'E') { + my ($tagname) = ($t->[1]); + if ($javafiles{'codebase'} ne '') { + $javafiles{'codebase'} .= '/'; + } + if (lc($tagname) eq 'applet' || + lc($tagname) eq 'object' || + (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object') + ) { + foreach my $item (keys(%javafiles)) { + if ($item ne 'codebase' && $javafiles{$item} ne '') { + my $file=$javafiles{'codebase'}.$javafiles{$item}; + &add_filetype($allfiles,$file,$item); + } + } + } + pop @state; + } + } + return 'ok'; +} + +sub add_filetype { + my ($allfiles,$file,$type)=@_; + if (exists($allfiles->{$file})) { + unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) { + push(@{$allfiles->{$file}}, &escape($type)); + } + } else { + @{$allfiles->{$file}} = (&escape($type)); + } +} + sub removeuploadedurl { my ($url)=@_; my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); @@ -1417,9 +1564,9 @@ sub flushcourselogs { ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:); if (! defined($dom) || $dom eq '' || ! defined($name) || $name eq '') { - my $cid = $ENV{'request.course.id'}; - $dom = $ENV{'request.'.$cid.'.domain'}; - $name = $ENV{'request.'.$cid.'.num'}; + my $cid = $env{'request.course.id'}; + $dom = $env{'request.'.$cid.'.domain'}; + $name = $env{'request.'.$cid.'.num'}; } my $value = $accesshash{$entry}; my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/); @@ -1462,50 +1609,50 @@ sub flushcourselogs { sub courselog { my $what=shift; $what=time.':'.$what; - unless ($ENV{'request.course.id'}) { return ''; } - $coursedombuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; - $coursenumbuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; - $coursehombuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; - $coursedescrbuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; - $courseinstcodebuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; - $courseownerbuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'}; - if (defined $courselogs{$ENV{'request.course.id'}}) { - $courselogs{$ENV{'request.course.id'}}.='&'.$what; + unless ($env{'request.course.id'}) { return ''; } + $coursedombuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.domain'}; + $coursenumbuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.num'}; + $coursehombuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.home'}; + $coursedescrbuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.description'}; + $courseinstcodebuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'}; + $courseownerbuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'}; + if (defined $courselogs{$env{'request.course.id'}}) { + $courselogs{$env{'request.course.id'}}.='&'.$what; } else { - $courselogs{$ENV{'request.course.id'}}.=$what; + $courselogs{$env{'request.course.id'}}.=$what; } - if (length($courselogs{$ENV{'request.course.id'}})>4048) { + if (length($courselogs{$env{'request.course.id'}})>4048) { &flushcourselogs(); } } sub courseacclog { my $fnsymb=shift; - unless ($ENV{'request.course.id'}) { return ''; } - my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; + unless ($env{'request.course.id'}) { return ''; } + my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { $what.=':POST'; # FIXME: Probably ought to escape things.... - foreach (keys %ENV) { + foreach (keys %env) { if ($_=~/^form\.(.*)/) { - $what.=':'.$1.'='.$ENV{$_}; + $what.=':'.$1.'='.$env{$_}; } } } elsif ($fnsymb =~ m:^/adm/searchcat:) { # FIXME: We should not be depending on a form parameter that someone # editing lonsearchcat.pm might change in the future. - if ($ENV{'form.phase'} eq 'course_search') { + if ($env{'form.phase'} eq 'course_search') { $what.= ':POST'; # FIXME: Probably ought to escape things.... foreach my $element ('courseexp','crsfulltext','crsrelated', 'crsdiscuss') { - $what.=':'.$element.'='.$ENV{'form.'.$element}; + $what.=':'.$element.'='.$env{'form.'.$element}; } } } @@ -1515,8 +1662,8 @@ sub courseacclog { sub countacc { my $url=&declutter(shift); return if (! defined($url) || $url eq ''); - unless ($ENV{'request.course.id'}) { return ''; } - $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; + unless ($env{'request.course.id'}) { return ''; } + $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; $accesshash{$key}++; } @@ -1543,7 +1690,7 @@ sub userrolelog { sub get_course_adv_roles { my $cid=shift; - $cid=$ENV{'request.course.id'} unless (defined($cid)); + $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); my %nothide=(); foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { @@ -1575,8 +1722,8 @@ sub get_course_adv_roles { sub get_my_roles { my ($uname,$udom)=@_; - unless (defined($uname)) { $uname=$ENV{'user.name'}; } - unless (defined($udom)) { $udom=$ENV{'user.domain'}; } + unless (defined($uname)) { $uname=$env{'user.name'}; } + unless (defined($udom)) { $udom=$env{'user.domain'}; } my %dumphash= &dump('nohist_userroles',$udom,$uname); my %returnhash=(); @@ -1631,7 +1778,7 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_; + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } foreach my $tryserver (keys %libserv) { @@ -1640,7 +1787,7 @@ sub courseiddump { foreach ( split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. $sincefilter.':'.&escape($descfilter).':'. - &escape($instcodefilter).':'.&escape($ownerfilter), + &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter), $tryserver))) { my ($key,$value)=split(/\=/,$_); if (($key) && ($value)) { @@ -1751,7 +1898,7 @@ sub checkin { unless (&allowed('mgr',$tcrsid)) { &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. - $ENV{'user.name'}.' - '.$ENV{'user.domain'}); + $env{'user.name'}.' - '.$env{'user.domain'}); return ''; } @@ -1775,15 +1922,15 @@ sub checkin { sub expirespread { my ($uname,$udom,$stype,$usymb)=@_; - my $cid=$ENV{'request.course.id'}; + my $cid=$env{'request.course.id'}; if ($cid) { my $now=time; my $key=$uname.':'.$udom.':'.$stype.':'.$usymb; - return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'. - $ENV{'course.'.$cid.'.num'}. + return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'. + $env{'course.'.$cid.'.num'}. ':nohist_expirationdates:'. &escape($key).'='.$now, - $ENV{'course.'.$cid.'.home'}) + $env{'course.'.$cid.'.home'}) } return 'ok'; } @@ -1792,7 +1939,7 @@ sub expirespread { sub devalidate { my ($symb,$uname,$udom)=@_; - my $cid=$ENV{'request.course.id'}; + my $cid=$env{'request.course.id'}; if ($cid) { # delete the stored spreadsheets for # - the student level sheet of this user in course's homespace @@ -1803,8 +1950,8 @@ sub devalidate { my $status= &del('nohist_calculatedsheets', [$key.'studentcalc:'], - $ENV{'course.'.$cid.'.domain'}, - $ENV{'course.'.$cid.'.num'}) + $env{'course.'.$cid.'.domain'}, + $env{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, [$key.'assesscalc:'.$symb],$udom,$uname); @@ -2014,16 +2161,16 @@ sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'request.url'}; } + if (!$symb) { $symb= $env{'request.url'}; } } $symb=escape($symb); - if (!$namespace) { $namespace=$ENV{'request.state'}; } + if (!$namespace) { $namespace=$env{'request.state'}; } $namespace=~s/\//\_/g; $namespace=~s/\W//g; - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } if ($domain eq 'public' && $stuname eq 'public') { $stuname=$ENV{'REMOTE_ADDR'}; } @@ -2045,22 +2192,22 @@ sub tmpstore { if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'request.url'}; } + if (!$symb) { $symb= $env{'request.url'}; } } $symb=escape($symb); if (!$namespace) { # I don't think we would ever want to store this for a course. # it seems this will only be used if we don't have a course. - #$namespace=$ENV{'request.course.id'}; + #$namespace=$env{'request.course.id'}; #if (!$namespace) { - $namespace=$ENV{'request.state'}; + $namespace=$env{'request.state'}; #} } $namespace=~s/\//\_/g; $namespace=~s/\W//g; - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } if ($domain eq 'public' && $stuname eq 'public') { $stuname=$ENV{'REMOTE_ADDR'}; } @@ -2097,14 +2244,14 @@ sub tmprestore { if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'request.url'}; } + if (!$symb) { $symb= $env{'request.url'}; } } $symb=escape($symb); - if (!$namespace) { $namespace=$ENV{'request.state'}; } + if (!$namespace) { $namespace=$env{'request.state'}; } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } if ($domain eq 'public' && $stuname eq 'public') { $stuname=$ENV{'REMOTE_ADDR'}; } @@ -2149,18 +2296,18 @@ sub store { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } &devalidate($symb,$stuname,$domain); $symb=escape($symb); if (!$namespace) { - unless ($namespace=$ENV{'request.course.id'}) { + unless ($namespace=$env{'request.course.id'}) { return ''; } } - if (!$home) { $home=$ENV{'user.home'}; } + if (!$home) { $home=$env{'user.home'}; } $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; $$storehash{'host'}=$perlvar{'lonHostID'}; @@ -2185,18 +2332,18 @@ sub cstore { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } &devalidate($symb,$stuname,$domain); $symb=escape($symb); if (!$namespace) { - unless ($namespace=$ENV{'request.course.id'}) { + unless ($namespace=$env{'request.course.id'}) { return ''; } } - if (!$home) { $home=$ENV{'user.home'}; } + if (!$home) { $home=$env{'user.home'}; } $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; $$storehash{'host'}=$perlvar{'lonHostID'}; @@ -2225,13 +2372,13 @@ sub restore { $symb=&escape(&symbclean($symb)); } if (!$namespace) { - unless ($namespace=$ENV{'request.course.id'}) { + unless ($namespace=$env{'request.course.id'}) { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } - if (!$home) { $home=$ENV{'user.home'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } + if (!$home) { $home=$env{'user.home'}; } my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); my %returnhash=(); @@ -2273,7 +2420,7 @@ sub coursedescription { } $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. - $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; + $env{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.home'}=$chome; $envhash{'course.'.$normalid.'.domain'}=$cdomain; $envhash{'course.'.$normalid.'.num'}=$cnum; @@ -2353,7 +2500,7 @@ sub rolesinit { my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); $userroles.='user.adv='.$adv."\n". 'user.author='.$author."\n"; - $ENV{'user.adv'}=$adv; + $env{'user.adv'}=$adv; } return $userroles; } @@ -2445,8 +2592,8 @@ sub get { $items.=escape($_).'&'; } $items=~s/\&$//; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); @@ -2472,8 +2619,8 @@ sub del { $items.=escape($_).'&'; } $items=~s/\&$//; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); return &reply("del:$udomain:$uname:$namespace:$items",$uhome); @@ -2483,8 +2630,8 @@ sub del { sub dump { my ($namespace,$udomain,$uname,$regexp)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); if ($regexp) { $regexp=&escape($regexp); @@ -2505,8 +2652,8 @@ sub dump { sub getkeys { my ($namespace,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); my @keyarray=(); @@ -2519,9 +2666,9 @@ sub getkeys { # --------------------------------------------------------------- currentdump sub currentdump { my ($courseid,$sdom,$sname)=@_; - $courseid = $ENV{'request.course.id'} if (! defined($courseid)); - $sdom = $ENV{'user.domain'} if (! defined($sdom)); - $sname = $ENV{'user.name'} if (! defined($sname)); + $courseid = $env{'request.course.id'} if (! defined($courseid)); + $sdom = $env{'user.domain'} if (! defined($sdom)); + $sname = $env{'user.name'} if (! defined($sname)); my $uhome = &homeserver($sname,$sdom); my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); return if ($rep =~ /^(error:|no_such_host)/); @@ -2575,12 +2722,18 @@ sub convert_dump_to_currentdump{ return \%returnhash; } +# ------------------------------------------------------ critical inc interface + +sub cinc { + return &inc(@_,'critical'); +} + # --------------------------------------------------------------- inc interface sub inc { - my ($namespace,$store,$udomain,$uname) = @_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + my ($namespace,$store,$udomain,$uname,$critical) = @_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; if (! ref($store)) { @@ -2596,15 +2749,19 @@ sub inc { } } $items=~s/\&$//; - return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); + if ($critical) { + return &critical("inc:$udomain:$uname:$namespace:$items",$uhome); + } else { + return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); + } } # --------------------------------------------------------------- put interface sub put { my ($namespace,$storehash,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; foreach (keys %$storehash) { @@ -2614,12 +2771,27 @@ sub put { return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } -# ---------------------------------------------------------- putstore interface - +# ------------------------------------------------------------ newput interface + +sub newput { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + foreach my $key (keys(%$storehash)) { + $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; + } + $items=~s/\&$//; + return &reply("newput:$udomain:$uname:$namespace:$items",$uhome); +} + +# --------------------------------------------------------- putstore interface + sub putstore { my ($namespace,$storehash,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; my %allitems = (); @@ -2642,8 +2814,8 @@ sub putstore { sub cput { my ($namespace,$storehash,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; foreach (keys %$storehash) { @@ -2662,8 +2834,8 @@ sub eget { $items.=escape($_).'&'; } $items=~s/\&$//; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); @@ -2680,7 +2852,7 @@ sub eget { sub customaccess { my ($priv,$uri)=@_; - my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); + my ($urole,$urealm)=split(/\./,$env{'request.role'}); $urealm=~s/^\W//; my ($udom,$ucrs,$usec)=split(/\//,$urealm); my $access=0; @@ -2720,7 +2892,7 @@ sub allowed { - if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } + if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { @@ -2729,8 +2901,8 @@ sub allowed { # Free bre access to user's own portfolio contents my ($space,$domain,$name,$dir)=split('/',$uri); - if (($space=~/^(uploaded|ediupload)$/) && ($ENV{'user.name'} eq $name) && - ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { + if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && + ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { return 'F'; } @@ -2738,23 +2910,23 @@ sub allowed { if ($priv eq 'bre') { my $copyright=&metadata($uri,'copyright'); - if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { + if (($copyright eq 'public') && (!$env{'request.course.id'})) { return 'F'; } if ($copyright eq 'priv') { $uri=~/([^\/]+)\/([^\/]+)\//; - unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { + unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) { return ''; } } if ($copyright eq 'domain') { $uri=~/([^\/]+)\/([^\/]+)\//; - unless (($ENV{'user.domain'} eq $1) || - ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) { + unless (($env{'user.domain'} eq $1) || + ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) { return ''; } } - if ($ENV{'request.role'}=~ /li\.\//) { + if ($env{'request.role'}=~ /li\.\//) { # Library role, so allow browsing of resources in this domain. return 'F'; } @@ -2763,11 +2935,11 @@ sub allowed { } } # Domain coordinator is trying to create a course - if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) { # uri is the requested domain in this case. # comparison to 'request.role.domain' shows if the user has selected # a role of dc for the domain in question. - return 'F' if ($uri eq $ENV{'request.role.domain'}); + return 'F' if ($uri eq $env{'request.role.domain'}); } my $thisallowed=''; @@ -2776,13 +2948,13 @@ sub allowed { # Course - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { + if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } # Domain - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} + if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -2792,7 +2964,7 @@ sub allowed { $courseuri=~s/\_(\d)/\/$1/; $courseuri=~s/^([^\/])/\/$1/; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} + if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -2800,7 +2972,7 @@ sub allowed { # URI is an uploaded document for this course # not allowing 'edit' access (editupload) to uploaded course docs if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { - my $refuri=$ENV{'httpref.'.$orguri}; + my $refuri=$env{'httpref.'.$orguri}; if ($refuri) { if ($refuri =~ m|^/adm/|) { $thisallowed='F'; @@ -2816,7 +2988,16 @@ sub allowed { # If this is generating or modifying users, exit with special codes - if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) { + if (($priv eq 'cca') || ($priv eq 'caa')) { + my ($audom,$auname)=split('/',$uri); +# no author name given, so this just checks on the general right to make a co-author in this domain + unless ($auname) { return $thisallowed; } +# an author name is given, so we are about to actually make a co-author for a certain account + if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) || + (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) && + ($audom ne $env{'request.role.domain'}))) { return ''; } + } return $thisallowed; } # @@ -2825,18 +3006,18 @@ sub allowed { # Course: See if uri or referer is an individual resource that is part of # the course - if ($ENV{'request.course.id'}) { + if ($env{'request.course.id'}) { - $courseprivid=$ENV{'request.course.id'}; - if ($ENV{'request.course.sec'}) { - $courseprivid.='/'.$ENV{'request.course.sec'}; + $courseprivid=$env{'request.course.id'}; + if ($env{'request.course.sec'}) { + $courseprivid.='/'.$env{'request.course.sec'}; } $courseprivid=~s/\_/\//; my $checkreferer=1; my ($match,$cond)=&is_on_map($uri); if ($match) { $statecond=$cond; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; @@ -2844,16 +3025,16 @@ sub allowed { } if ($checkreferer) { - my $refuri=$ENV{'httpref.'.$orguri}; + my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { - foreach (keys %ENV) { + foreach (keys %env) { if ($_=~/^httpref\..*\*/) { my $pattern=$_; $pattern=~s/^httpref\.\/res\///; $pattern=~s/\*/\[\^\/\]\+/g; $pattern=~s/\//\\\//g; if ($orguri=~/$pattern/) { - $refuri=$ENV{$_}; + $refuri=$env{$_}; } } } @@ -2864,7 +3045,7 @@ sub allowed { my ($match,$cond)=&is_on_map($refuri); if ($match) { my $refstatecond=$cond; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; @@ -2904,39 +3085,39 @@ sub allowed { my $envkey; if ($thisallowed=~/L/) { - foreach $envkey (keys %ENV) { + foreach $envkey (keys %env) { if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { my $courseid=$2; my $roleid=$1.'.'.$2; $courseid=~s/^\///; my $expiretime=600; - if ($ENV{'request.role'} eq $roleid) { + if ($env{'request.role'} eq $roleid) { $expiretime=120; } my ($cdom,$cnum,$csec)=split(/\//,$courseid); my $prefix='course.'.$cdom.'_'.$cnum.'.'; - if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { + if ((time-$env{$prefix.'last_cache'})>$expiretime) { &coursedescription($courseid); } - if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) - || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { - if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { - &log($ENV{'user.domain'},$ENV{'user.name'}, - $ENV{'user.home'}, + if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) + || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { + if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) { + &log($env{'user.domain'},$env{'user.name'}, + $env{'user.home'}, 'Locked by res: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. - $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); + $env{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; } } - if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) - || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { - if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { - &log($ENV{'user.domain'},$ENV{'user.name'}, - $ENV{'user.home'}, + if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) + || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { + if ($env{'priv.'.$priv.'.lock.expire'}>time) { + &log($env{'user.domain'},$env{'user.name'}, + $env{'user.home'}, 'Locked by priv: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. - $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); + $env{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; } } @@ -2948,7 +3129,7 @@ sub allowed { # Rest of the restrictions depend on selected course # - unless ($ENV{'request.course.id'}) { + unless ($env{'request.course.id'}) { return '1'; } @@ -2960,21 +3141,21 @@ sub allowed { # Course preferences if ($thisallowed=~/C/) { - my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; - my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; - if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} + my $rolecode=(split(/\./,$env{'request.role'}))[0]; + my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; + if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\Q$rolecode\E/) { - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. - $ENV{'request.course.id'}); + $env{'request.course.id'}); return ''; } - if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} + if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} =~/\Q$unamedom\E/) { - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. - $ENV{'request.course.id'}); + $env{'request.course.id'}); return ''; } } @@ -2982,9 +3163,9 @@ sub allowed { # Resource preferences if ($thisallowed=~/R/) { - my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + my $rolecode=(split(/\./,$env{'request.role'}))[0]; if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); return ''; } @@ -2993,9 +3174,9 @@ sub allowed { # Restricted by state or randomout? if ($thisallowed=~/X/) { - if ($ENV{'acc.randomout'}) { + if ($env{'acc.randomout'}) { if (!$symb) { $symb=&symbread($uri,1); } - if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { + if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { return ''; } } @@ -3020,7 +3201,7 @@ sub is_on_map { $pathname=~s|/\Q$filename\E$||; $pathname=~s/^adm\/wrapper\///; #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\|]+)\&/); if ($match) { return (1,$1); @@ -3039,7 +3220,7 @@ sub get_symb_from_alias { # Must be an alias my $aliassymb=''; my %bighash; - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { my $rid=$bighash{'mapalias_'.$symb}; if ($rid) { @@ -3084,11 +3265,11 @@ sub definerole { } } } - my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". - "$ENV{'user.domain'}:$ENV{'user.name'}:". + my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". + "$env{'user.domain'}:$env{'user.name'}:". "rolesdef_$rolename=". escape($sysrole.'_'.$domrole.'_'.$courole); - return reply($command,$ENV{'user.home'}); + return reply($command,$env{'user.home'}); } else { return 'refused'; } @@ -3150,7 +3331,7 @@ sub fetch_enrollment_query { $cmd =~ s/%%$//; $cmd = &escape($cmd); my $query = 'fetchenrollment'; - my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); + my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver); unless ($queryid=~/^\Q$host\E\_/) { &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); return 'error: '.$queryid; @@ -3162,7 +3343,7 @@ sub fetch_enrollment_query { $tries ++; } if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { - &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); + &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); } else { my @responses = split/:/,$reply; if ($homeserver eq $perlvar{'lonHostID'}) { @@ -3227,14 +3408,14 @@ sub courselog_query { # end: timestamp # my (%filters)=@_; - unless ($ENV{'request.course.id'}) { return 'no_course'; } + unless ($env{'request.course.id'}) { return 'no_course'; } if ($filters{'url'}) { $filters{'url'}=&symbclean(&declutter($filters{'url'})); $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/; $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/; } - my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; - my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + my $cname=$env{'course.'.$env{'request.course.id'}.'.num'}; + my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'}; return &log_query($cname,$cdom,'courselog',%filters); } @@ -3302,8 +3483,8 @@ sub auto_instcode_format { last; } } - if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) { - $homeserver = &homeserver($ENV{'user.name'},$codedom); + if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) { + $homeserver = &homeserver($env{'user.name'},$codedom); } } else { $homeserver = &homeserver($caller,$codedom); @@ -3342,7 +3523,7 @@ sub assignrole { unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $env{'user.name'}.' at '.$env{'user.domain'}); return 'refused'; } $mrole='cr'; @@ -3352,12 +3533,12 @@ sub assignrole { unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $env{'user.name'}.' at '.$env{'user.domain'}); return 'refused'; } $mrole=$role; } - my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". + my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". "$udom:$uname:$url".'_'."$mrole=$role"; if ($end) { $command.='_'.$end; } if ($start) { @@ -3371,9 +3552,9 @@ sub assignrole { if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { # modify command to delete the role - $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". + $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:". "$udom:$uname:$url".'_'."$mrole"; - &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); + &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom"); # set start and finish to negative values for userrolelog $start=-1; $end=-1; @@ -3396,16 +3577,16 @@ sub modifyuserauth { my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. - $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. - ' in domain '.$ENV{'request.role.domain'}); + $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}. + ' in domain '.$env{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, 'Authentication changed for '.$udom.', '.$uname.', '.$umode. '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); &log($udom,,$uname,$uhome, - 'Authentication changed by '.$ENV{'user.domain'}.', '. - $ENV{'user.name'}.', '.$umode. + 'Authentication changed by '.$env{'user.domain'}.', '. + $env{'user.name'}.', '.$umode. '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); unless ($reply eq 'ok') { &logthis('Authentication mode error: '.$reply); @@ -3428,8 +3609,8 @@ sub modifyuser { $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). - ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. - ' in domain '.$ENV{'request.role.domain'}); + ' by '.$env{'user.name'}.' at '.$env{'user.domain'}. + ' in domain '.$env{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && @@ -3437,8 +3618,8 @@ sub modifyuser { my $unhome=''; if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { $unhome = $desiredhome; - } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { - $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { + $unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; } else { # load balancing routine for determining $unhome my $tryserver; my $loadm=10000000; @@ -3509,7 +3690,7 @@ sub modifyuser { &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. $last.', '.$gene.' by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $env{'user.name'}.' at '.$env{'user.domain'}); return 'ok'; } @@ -3519,7 +3700,7 @@ sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; if (!$cid) { - unless ($cid=$ENV{'request.course.id'}) { + unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; } } @@ -3540,15 +3721,15 @@ sub modify_student_enrollment { my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; my ($cdom,$cnum,$chome); if (!$cid) { - unless ($cid=$ENV{'request.course.id'}) { + unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; } - $cdom=$ENV{'course.'.$cid.'.domain'}; - $cnum=$ENV{'course.'.$cid.'.num'}; + $cdom=$env{'course.'.$cid.'.domain'}; + $cnum=$env{'course.'.$cid.'.num'}; } else { ($cdom,$cnum)=split(/_/,$cid); } - $chome=$ENV{'course.'.$cid.'.home'}; + $chome=$env{'course.'.$cid.'.home'}; if (!$chome) { $chome=&homeserver($cnum,$cdom); } @@ -3657,7 +3838,7 @@ sub createcourse { } } # ------------------------------------------------ Check supplied server name - $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + $course_server = $env{'user.homeserver'} if (! defined($course_server)); if (! exists($libserv{$course_server})) { return 'error:bad server name '.$course_server; } @@ -3680,7 +3861,7 @@ sub createcourse { # ------------------------------------------ For standard courses, make top url my $mapurl=&clutter($url); if ($mapurl eq '/res/') { $mapurl=''; } - $ENV{'form.initmap'}=(< @@ -3690,7 +3871,7 @@ sub createcourse { ENDINITMAP $topurl=&declutter( - &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + &finishuserfileupload($uname,$udom,'initmap','default.sequence') ); } # ----------------------------------------------------------- Write preferences @@ -3739,7 +3920,7 @@ sub is_locked { my $is_locked; push @check, $file_name; my %locked = &get('file_permissions',\@check, - $ENV{'user.domain'},$ENV{'user.name'}); + $env{'user.domain'},$env{'user.name'}); my ($tmp)=keys(%locked); if ($tmp=~/^error:/) { undef(%locked); } @@ -3757,7 +3938,6 @@ sub mark_as_readonly { my %current_permissions = &dump('file_permissions',$domain,$user); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } - foreach my $file (@{$files}) { push(@{$current_permissions{$file}},$what); } @@ -3773,7 +3953,7 @@ sub save_selected_files { my @other_files = &files_not_in_path($user, $path); open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); foreach my $file (@files) { - print (OUT $ENV{'form.currentpath'}.$file."\n"); + print (OUT $env{'form.currentpath'}.$file."\n"); } foreach my $file (@other_files) { print (OUT $file."\n"); @@ -3836,17 +4016,21 @@ sub files_not_in_path { #--------------------------------------------------------------Get Marked as Read Only + sub get_marked_as_readonly { my ($domain,$user,$what) = @_; my %current_permissions = &dump('file_permissions',$domain,$user); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } - my @readonly_files; + my $cmp1=$what; + if (ref($what)) { $cmp1=join('',@{$what}) }; while (my ($file_name,$value) = each(%current_permissions)) { if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { - if ($stored_what eq $what) { + my $cmp2=$stored_what; + if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) }; + if ($cmp1 eq $cmp2) { push(@readonly_files, $file_name); } elsif (!defined($what)) { push(@readonly_files, $file_name); @@ -3881,13 +4065,14 @@ sub get_marked_as_readonly_hash { # ------------------------------------------------------------ Unmark as Read Only sub unmark_as_readonly { - # unmarks all files locked by $what - # for portfolio submissions, $what contains $crsid and $symb - my ($domain,$user,$what) = @_; + # unmarks $file_name (if $file_name is defined), or all files locked by $what + # for portfolio submissions, $what contains [$symb,$crsid] + my ($domain,$user,$what,$file_name) = @_; + my $symb_crs = $what; + if (ref($what)) { $symb_crs=join('',@$what); } my %current_permissions = &dump('file_permissions',$domain,$user); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } - my @readonly_files = &get_marked_as_readonly($domain,$user,$what); foreach my $file(@readonly_files){ my $current_locks = $current_permissions{$file}; @@ -3895,7 +4080,13 @@ sub unmark_as_readonly { my @del_keys; if (ref($current_locks) eq "ARRAY"){ foreach my $locker (@{$current_locks}) { - unless ($locker eq $what) { + my $compare=$locker; + if (ref($locker)) { $compare=join('',@{$locker}) }; + if ($compare eq $symb_crs) { + if (defined($file_name) && ($file_name ne $file)) { + push(@new_locks, $what); + } + } else { push(@new_locks, $what); } } @@ -4038,11 +4229,11 @@ sub GetFileTimestamp { sub directcondval { my $number=shift; - if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) { + if (!defined($env{'user.state.'.$env{'request.course.id'}})) { &Apache::lonuserstate::evalstate(); } - if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { - return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); + if ($env{'user.state.'.$env{'request.course.id'}}) { + return substr($env{'user.state.'.$env{'request.course.id'}},$number,1); } else { return 2; } @@ -4053,13 +4244,13 @@ sub condval { my $result=0; my $allpathcond=''; foreach (split(/\|/,$condidx)) { - if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { + if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) { $allpathcond.= - '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; + '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|'; } } $allpathcond=~s/\|$//; - if ($ENV{'request.course.id'}) { + if ($env{'request.course.id'}) { if ($allpathcond) { my $operand='|'; my @stack; @@ -4099,13 +4290,14 @@ sub devalidatecourseresdata { # --------------------------------------------------- Course Resourcedata Query -sub courseresdata { - my ($coursenum,$coursedomain,@which)=@_; +sub get_courseresdata { + my ($coursenum,$coursedomain)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; my ($result,$cached)=&is_cached_new('courseres',$hashid); + my %dumpreply; unless (defined($cached)) { - my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); $result=\%dumpreply; my ($tmp) = keys(%dumpreply); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { @@ -4117,6 +4309,54 @@ sub courseresdata { &do_cache_new('courseres',$hashid,$result,600); } } + return $result; +} + +sub devalidateuserresdata { + my ($uname,$udom)=@_; + my $hashid="$udom:$uname"; + &devalidate_cache_new('userres',$hashid); +} + +sub get_userresdata { + my ($uname,$udom)=@_; + #most student don\'t have any data set, check if there is some data + if (&EXT_cache_status($udom,$uname)) { return undef; } + + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached_new('userres',$hashid); + if (!defined($cached)) { + my %resourcedata=&dump('resourcedata',$udom,$uname); + $result=\%resourcedata; + &do_cache_new('userres',$hashid,$result,600); + } + my ($tmp)=keys(%$result); + if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { + return $result; + } + #error 2 occurs when the .db doesn't exist + if ($tmp!~/error: 2 /) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); + } elsif ($tmp=~/error: 2 /) { + #&EXT_cache_set($udom,$uname); + &do_cache_new('userres',$hashid,undef,600); + undef($tmp); # not really an error so don't send it back + } + return $tmp; +} + +sub resdata { + my ($name,$domain,$type,@which)=@_; + my $result; + if ($type eq 'course') { + $result=&get_courseresdata($name,$domain); + } elsif ($type eq 'user') { + $result=&get_userresdata($name,$domain); + } + if (!ref($result)) { return $result; } foreach my $item (@which) { if (defined($result->{$item})) { return $result->{$item}; @@ -4136,7 +4376,7 @@ sub clear_EXT_cache_status { sub EXT_cache_status { my ($target_domain,$target_user) = @_; my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; - if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { + if (exists($env{$cachename}) && ($env{$cachename}+600) > time) { # We know already the user has no data return 1; } else { @@ -4147,7 +4387,7 @@ sub EXT_cache_status { sub EXT_cache_set { my ($target_domain,$target_user) = @_; my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; - &appenv($cachename => time); + #&appenv($cachename => time); } # --------------------------------------------------------- Value of a Variable @@ -4166,7 +4406,7 @@ sub EXT { &Apache::lonxml::whichuser($symbparm); if (!$symbparm) { $symbparm=$cursymb; } } else { - $courseid=$ENV{'request.course.id'}; + $courseid=$env{'request.course.id'}; } my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; @@ -4188,7 +4428,7 @@ sub EXT { return $Apache::lonhomework::history{$qualifierrest}; } else { my %restored; - if ($publicuser || $ENV{'request.state'} eq 'construct') { + if ($publicuser || $env{'request.state'} eq 'construct') { %restored=&tmprestore($symbparm,$courseid,$udom,$uname); } else { %restored=&restore($symbparm,$courseid,$udom,$uname); @@ -4201,9 +4441,9 @@ sub EXT { return &allowed($qualifier,$rest); # ------------------------------------------ user.preferences, user.environment } elsif (($space eq 'preferences') || ($space eq 'environment')) { - if (($uname eq $ENV{'user.name'}) && - ($udom eq $ENV{'user.domain'})) { - return $ENV{join('.',('environment',$qualifierrest))}; + if (($uname eq $env{'user.name'}) && + ($udom eq $env{'user.domain'})) { + return $env{join('.',('environment',$qualifierrest))}; } else { my %returnhash; if (!$publicuser) { @@ -4215,11 +4455,11 @@ sub EXT { # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { # FIXME - not supporting calls for a specific user - return $ENV{join('.',('request.course',$qualifier))}; + return $env{join('.',('request.course',$qualifier))}; # ------------------------------------------------------------------- user.role } elsif ($space eq 'role') { # FIXME - not supporting calls for a specific user - my ($role,$where)=split(/\./,$ENV{'request.role'}); + my ($role,$where)=split(/\./,$env{'request.role'}); if ($qualifier eq 'value') { return $role; } elsif ($qualifier eq 'extent') { @@ -4243,7 +4483,7 @@ sub EXT { # ---------------------------------------------- pull stuff out of query string &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, [$spacequalifierrest]); - return $ENV{'form.'.$spacequalifierrest}; + return $env{'form.'.$spacequalifierrest}; } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { @@ -4254,24 +4494,24 @@ sub EXT { return 0; } } else { - return $ENV{'browser.'.$qualifier}; + return $env{'browser.'.$qualifier}; } # ------------------------------------------------------------ request.filename } else { - return $ENV{'request.'.$spacequalifierrest}; + return $env{'request.'.$spacequalifierrest}; } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; + return $env{'course.'.$courseid.'.'.$spacequalifierrest}; } 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(); } } my ($courselevelm,$courselevel); if ($symbparm && defined($courseid) && - $courseid eq $ENV{'request.course.id'}) { + $courseid eq $env{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -4282,9 +4522,9 @@ sub EXT { my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - if (($ENV{'user.name'} eq $uname) && - ($ENV{'user.domain'} eq $udom)) { - $section=$ENV{'request.course.sec'}; + if (($env{'user.name'} eq $uname) && + ($env{'user.domain'} eq $udom)) { + $section=$env{'request.course.sec'}; } else { if (! defined($usection)) { $section=&getsection($udom,$uname,$courseid); @@ -4302,51 +4542,27 @@ sub EXT { $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - #most student don\'t have any data set, check if there is some data - if (! &EXT_cache_status($udom,$uname)) { - my $hashid="$udom:$uname"; - my ($result,$cached)=&is_cached_new('userres',$hashid); - if (!defined($cached)) { - my %resourcedata=&dump('resourcedata',$udom,$uname); - $result=\%resourcedata; - &do_cache_new('userres',$hashid,$result); - } - my ($tmp)=keys(%$result); - if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { - if ($$result{$courselevelr}) { - return $$result{$courselevelr}; } - if ($$result{$courselevelm}) { - return $$result{$courselevelm}; } - if ($$result{$courselevel}) { - return $$result{$courselevel}; } - } else { - #error 2 occurs when the .db doesn't exist - if ($tmp!~/error: 2 /) { - &logthis("WARNING:". - " Trying to get resource data for ". - $uname." at ".$udom.": ". - $tmp.""); - } elsif ($tmp=~/error: 2 /) { - &EXT_cache_set($udom,$uname); - } elsif ($tmp =~ /^(con_lost|no_such_host)/) { - return $tmp; - } - } - } + + my $userreply=&resdata($uname,$udom,'user', + ($courselevelr,$courselevelm, + $courselevel)); + + if (defined($userreply)) { return $userreply; } # ------------------------------------------------ second, check some of course - my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, - $ENV{'course.'.$courseid.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr)); + my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($seclevelr,$seclevelm,$seclevel, + $courselevelr)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms my %parmhash=(); my $thisparm=''; if (tie(%parmhash,'GDBM_File', - $ENV{'request.course.fn'}.'_parms.db', + $env{'request.course.fn'}.'_parms.db', &GDBM_READER(),0640)) { $thisparm=$parmhash{$symbparm}; untie(%parmhash); @@ -4361,7 +4577,7 @@ sub EXT { if ($symbparm) { $filename=(&decode_symb($symbparm))[2]; } else { - $filename=$ENV{'request.filename'}; + $filename=$env{'request.filename'}; } my $metadata=&metadata($filename,$spacequalifierrest); if (defined($metadata)) { return $metadata; } @@ -4370,10 +4586,11 @@ sub EXT { # ---------------------------------------------- fourth, look in rest pf course if ($symbparm && defined($courseid) && - $courseid eq $ENV{'request.course.id'}) { - my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, - $ENV{'course.'.$courseid.'.domain'}, - ($courselevelm,$courselevel)); + $courseid eq $env{'request.course.id'}) { + my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($courselevelm,$courselevel)); if (defined($coursereply)) { return $coursereply; } } # ------------------------------------------------------------------ Cascade up @@ -4393,8 +4610,8 @@ sub EXT { # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { - return $ENV{'environment.'.$spacequalifierrest}; + if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { + return $env{'environment.'.$spacequalifierrest}; } else { my %returnhash=&userenvironment($udom,$uname, $spacequalifierrest); @@ -4601,7 +4818,6 @@ sub metadata { } my ($extension) = ($uri =~ /\.(\w+)$/); foreach my $key (sort(keys(%packagetab))) { - #&logthis("extsion1 $extension $key !!"); #no specific packages #how's our extension if ($key!~/^extension_\Q$extension\E&/) { next; } &metadata_create_package_def($uri,$key,'extension_'.$extension, @@ -4637,7 +4853,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); + &do_cache_new('meta',$uri,\%metaentry,60*60*24); # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -4689,7 +4905,7 @@ sub metadata_generate_part0 { '.type'}; my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. '.display'}; - my $expr='\\[Part: '.$allnames{$name}.'\\]'; + my $expr='[Part: '.$allnames{$name}.']'; $olddis=~s/\Q$expr\E/\[Part: 0\]/; $$metacache{"$key.display"}=$olddis; } @@ -4701,7 +4917,7 @@ sub gettitle { my $urlsymb=shift; my $symb=&symbread($urlsymb); if ($symb) { - my $key=$ENV{'request.course.id'}."\0".$symb; + my $key=$env{'request.course.id'}."\0".$symb; my ($result,$cached)=&is_cached_new('title',$key); if (defined($cached)) { return $result; @@ -4709,7 +4925,7 @@ sub gettitle { my ($map,$resid,$url)=&decode_symb($symb); my $title=''; my %bighash; - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { my $mapid=$bighash{'map_pc_'.&clutter($map)}; $title=$bighash{'title_'.$mapid.'.'.$resid}; @@ -4730,8 +4946,8 @@ sub get_slot { my ($which,$cnum,$cdom)=@_; if (!$cnum || !$cdom) { (undef,my $courseid)=&Apache::lonxml::whichuser(); - $cdom=$ENV{'course.'.$courseid.'.domain'}; - $cnum=$ENV{'course.'.$courseid.'.num'}; + $cdom=$env{'course.'.$courseid.'.domain'}; + $cnum=$env{'course.'.$courseid.'.num'}; } my %slotinfo=&get('slots',[$which],$cdom,$cnum); &Apache::lonhomework::showhash(%slotinfo); @@ -4748,8 +4964,8 @@ sub symblist { my ($mapname,%newhash)=@_; $mapname=&deversion(&declutter($mapname)); my %hash; - if (($ENV{'request.course.fn'}) && (%newhash)) { - if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', + if (($env{'request.course.fn'}) && (%newhash)) { + if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1], @@ -4785,7 +5001,7 @@ sub symbverify { my %bighash; my $okay=0; - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { @@ -4794,12 +5010,12 @@ sub symbverify { if ($ids) { # ------------------------------------------------------------------- Has ID(s) foreach (split(/\,/,$ids)) { - my ($mapid,$resid)=split(/\./,$_); + my ($mapid,$resid)=split(/\./,$_); if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { - if (($ENV{'request.role.adv'}) || - $bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) { + if (($env{'request.role.adv'}) || + $bighash{'encrypted_'.$_} eq $env{'request.enc'}) { $okay=1; } } @@ -4846,12 +5062,12 @@ sub fixversion { if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; } my %bighash; my $uri=&clutter($fn); - my $key=$ENV{'request.course.id'}.'_'.$uri; + my $key=$env{'request.course.id'}.'_'.$uri; # is this cached? my ($result,$cached)=&is_cached_new('courseresversion',$key); if (defined($cached)) { return $result; } # unfortunately not cached, or expired - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { if ($bighash{'version_'.$uri}) { my $version=$bighash{'version_'.$uri}; @@ -4876,31 +5092,31 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; my $cache_str='request.symbread.cached.'.$thisfn; - if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; } + if (defined($env{$cache_str})) { return $env{$cache_str}; } # no filename provided? try from environment unless ($thisfn) { - if ($ENV{'request.symb'}) { - return $ENV{$cache_str}=&symbclean($ENV{'request.symb'}); + if ($env{'request.symb'}) { + return $env{$cache_str}=&symbclean($env{'request.symb'}); } - $thisfn=$ENV{'request.filename'}; + $thisfn=$env{'request.filename'}; } if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } # is that filename actually a symb? Verify, clean, and return if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { if (&symbverify($thisfn,$1)) { - return $ENV{$cache_str}=&symbclean($thisfn); + return $env{$cache_str}=&symbclean($thisfn); } } $thisfn=declutter($thisfn); my %hash; my %bighash; my $syval=''; - if (($ENV{'request.course.fn'}) && ($thisfn)) { + if (($env{'request.course.fn'}) && ($thisfn)) { my $targetfn = $thisfn; if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { $targetfn = 'adm/wrapper/'.$thisfn; } - 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)) { $syval=$hash{$targetfn}; untie(%hash); @@ -4908,15 +5124,15 @@ sub symbread { # ---------------------------------------------------------- There was an entry if ($syval) { #unless ($syval=~/\_\d+$/) { - #unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { + #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { #&appenv('request.ambiguous' => $thisfn); - #return $ENV{$cache_str}=''; + #return $env{$cache_str}=''; #} #$syval.=$1; #} } else { # ------------------------------------------------------- Was not in symb table - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { # ---------------------------------------------- Get ID(s) for current resource my $ids=$bighash{'ids_'.&clutter($thisfn)}; @@ -4933,7 +5149,8 @@ sub symbread { if ($#possibilities==0) { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); - $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; + $syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; @@ -4943,8 +5160,8 @@ sub symbread { my ($mapid,$resid)=split(/\./,$_); if ($bighash{'map_type_'.$mapid} ne 'page') { $realpossible++; - $syval=declutter($bighash{'map_id_'.$mapid}). - '___'.$resid; + $syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); } } } @@ -4957,12 +5174,11 @@ sub symbread { } } if ($syval) { - return $ENV{$cache_str}=$syval; - #return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); + return $env{$cache_str}=$syval; } } &appenv('request.ambiguous' => $thisfn); - return $ENV{$cache_str}=''; + return $env{$cache_str}=''; } # ---------------------------------------------------------- Return random seed @@ -5021,7 +5237,7 @@ sub get_rand_alg { my ($courseid)=@_; if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } if ($courseid) { - return $ENV{"course.$courseid.rndseed"}; + return $env{"course.$courseid.rndseed"}; } return &latest_rnd_algorithm_id(); } @@ -5033,7 +5249,7 @@ sub validCODE { } sub getCODE { - if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } + if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; } if ( (defined($Apache::lonhomework::parsing_a_problem) || defined($Apache::lonhomework::parsing_a_task) ) && &validCODE($Apache::lonhomework::history{'resource.CODE'})) { @@ -5236,8 +5452,8 @@ sub latest_receipt_algorithm_id { sub recunique { my $fucourseid=shift; my $unique; - if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { - $unique=$ENV{"course.$fucourseid.internal.encseed"}; + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $unique=$env{"course.$fucourseid.internal.encseed"}; } else { $unique=$perlvar{'lonReceipt'}; } @@ -5247,8 +5463,8 @@ sub recunique { sub recprefix { my $fucourseid=shift; my $prefix; - if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { - $prefix=$ENV{"course.$fucourseid.internal.encpref"}; + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $prefix=$env{"course.$fucourseid.internal.encpref"}; } else { $prefix=$perlvar{'lonHostID'}; } @@ -5264,8 +5480,8 @@ sub ireceipt { my $cunique=&recunique($fucourseid); my $cpart=unpack("%32S*",$part); my $return =&recprefix($fucourseid).'-'; - if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' || - $ENV{'request.state'} eq 'construct') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || + $env{'request.state'} eq 'construct') { &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). " and ".($cpart%$cudom)); @@ -5378,12 +5594,12 @@ sub tokenwrapper { my $uri=shift; $uri=~s|^http\://([^/]+)||; $uri=~s|^/||; - $ENV{'user.environment'}=~/\/([^\/]+)\.id/; + $env{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; my (undef,$udom,$uname,$file)=split('/',$uri,4); if ($udom && $uname && $file) { $file=~s|(\?\.*)*$||; - &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'}); + &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; @@ -5933,14 +6149,14 @@ that was requested X B: the value of %hash is written to the user envirnoment file, and will be restored for each access this -user makes during this session, also modifies the %ENV for the current +user makes during this session, also modifies the %env for the current process =item * X B: removes all items from the session environment file that matches the regular expression in $regexp. The -values are also delted from the current processes %ENV. +values are also delted from the current processes %env. =back @@ -6153,13 +6369,17 @@ revokecustomrole($udom,$uname,$url,$role =item * -coursedescription($courseid) : course description +coursedescription($courseid) : returns a hash of information about the +specified course id, including all environment settings for the +course, the description of the course will be in the hash under the +key 'description' =item * -courseresdata($coursenum,$coursedomain,@which) : request for current -parameter setting for a specific course, @what should be a list of -parameters to ask about. This routine caches answers for 5 minutes. +resdata($name,$domain,$type,@which) : request for current parameter +setting for a specific $type, where $type is either 'course' or 'user', +@what should be a list of parameters to ask about. This routine caches +answers for 5 minutes. =back @@ -6248,7 +6468,7 @@ symbverify($symb,$thisfn) : verifies tha a possible symb for the URL in $thisfn, and if is an encryypted resource that the user accessed using /enc/ returns a 1 on success, 0 on failure, user must be in a course, as it assumes the existance of -the course initial hash, and uses $ENV('request.course.id'} +the course initial hash, and uses $env('request.course.id'} =item * @@ -6279,7 +6499,7 @@ unfakeable, receipt =item * -receipt() : API to ireceipt working off of ENV values; given out to users +receipt() : API to ireceipt working off of env values; given out to users =item * @@ -6313,7 +6533,7 @@ forcing spreadsheet to reevaluate the re store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently for this url; hashref needs to be given and should be a \%hashname; the remaining args aren't required and if they aren't passed or are '' they will -be derived from the ENV +be derived from the env =item * @@ -6542,10 +6762,10 @@ declutter() : declutters URLs (remove do userfileupload(): main rotine for putting a file in a user or course's filespace, arguments are, - formname - required - this is the name of the element in $ENV where the + formname - required - this is the name of the element in $env where the filename, and the contents of the file to create/modifed exist - the filename is in $ENV{'form.'.$formname.'.filename'} and the - contents of the file is located in $ENV{'form.'.$formname} + the filename is in $env{'form.'.$formname.'.filename'} and the + contents of the file is located in $env{'form.'.$formname} coursedoc - if true, store the file in the course of the active role of the current user subdir - required - subdirectory to put the file in under ../userfiles/ @@ -6574,7 +6794,6 @@ userspace, probably shouldn't be called docuname: username or courseid of destination for the file docudom: domain of user/course of destination for the file - docuhome: loncapa id of the library server that is getting the file formname: same as for userfileupload() fname: filename (inculding subdirectories) for the file