--- loncom/lonnet/perl/lonnet.pm 2005/04/05 20:43:27 1.619
+++ loncom/lonnet/perl/lonnet.pm 2005/09/01 06:45:30 1.653
@@ -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.653 2005/09/01 06:45:30 albertel 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 {
.'</font>');
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,16 +757,23 @@ 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\#/);
}
# ------------------------------------- Find the section of student in a course
+sub devalidate_getsection_cache {
+ my ($udom,$unam,$courseid)=@_;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+ my $hashid="$udom:$unam:$courseid";
+ &devalidate_cache_new('getsection',$hashid);
+}
sub getsection {
my ($udom,$unam,$courseid)=@_;
@@ -845,7 +835,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 +886,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 +955,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 +1139,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 +1162,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 +1190,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 +1281,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 +1300,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 +1348,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 +1374,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 +1571,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 +1616,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 +1669,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 +1697,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 +1729,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 +1785,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 +1794,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 +1905,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 +1929,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 +1946,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 +1957,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 +2168,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 +2199,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 +2251,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 +2303,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 +2339,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 +2379,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 +2427,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 +2507,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 +2599,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 +2626,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 +2637,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 +2659,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 +2673,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 +2729,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 +2756,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 +2778,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 +2821,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 +2841,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 +2859,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 +2899,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 +2908,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 +2917,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 +2942,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 +2955,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 +2971,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 +2979,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 +2995,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 +3013,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 +3032,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 +3052,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 +3092,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 +3136,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 +3148,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 +3170,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 +3181,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 +3208,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 +3227,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 +3272,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 +3338,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 +3350,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 +3415,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 +3490,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 +3530,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 +3540,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 +3559,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 +3584,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 +3616,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 +3625,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 +3697,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 +3707,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 +3728,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);
}
@@ -3586,6 +3774,8 @@ sub modify_student_enrollment {
$cdom,$cnum);
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return 'error: '.$reply;
+ } else {
+ &devalidate_getsection_cache($udom,$uname,$cid);
}
# Add student role to user
my $uurl='/'.$cid;
@@ -3657,7 +3847,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 +3870,7 @@ sub createcourse {
# ------------------------------------------ For standard courses, make top url
my $mapurl=&clutter($url);
if ($mapurl eq '/res/') { $mapurl=''; }
- $ENV{'form.initmap'}=(<<ENDINITMAP);
+ $env{'form.initmap'}=(<<ENDINITMAP);
<map>
<resource id="1" type="start"></resource>
<resource id="2" src="$mapurl"></resource>
@@ -3690,7 +3880,7 @@ sub createcourse {
</map>
ENDINITMAP
$topurl=&declutter(
- &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
+ &finishuserfileupload($uname,$udom,'initmap','default.sequence')
);
}
# ----------------------------------------------------------- Write preferences
@@ -3739,7 +3929,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 +3947,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 +3962,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 +4025,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,30 +4074,34 @@ 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};
+ foreach my $file (@readonly_files) {
+ if (defined($file_name) && ($file_name ne $file)) { next; }
+ my $current_locks = $current_permissions{$file};
my @new_locks;
my @del_keys;
if (ref($current_locks) eq "ARRAY"){
foreach my $locker (@{$current_locks}) {
- unless ($locker eq $what) {
- push(@new_locks, $what);
+ my $compare=$locker;
+ if (ref($locker)) { $compare=join('',@{$locker}) };
+ if ($compare ne $symb_crs) {
+ push(@new_locks, $locker);
}
}
- if (@new_locks > 0) {
+ if (scalar(@new_locks) > 0) {
$current_permissions{$file} = \@new_locks;
} else {
push(@del_keys, $file);
&del('file_permissions',\@del_keys, $domain, $user);
- delete $current_permissions{$file};
+ delete($current_permissions{$file});
}
}
}
@@ -4038,11 +4235,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 +4250,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 +4296,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 +4315,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("<font color=blue>WARNING:".
+ " Trying to get resource data for ".
+ $uname." at ".$udom.": ".
+ $tmp."</font>");
+ } 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 +4382,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 +4393,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 +4412,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;
@@ -4183,12 +4429,14 @@ sub EXT {
if ($realm eq 'user') {
# --------------------------------------------------------------- user.resource
if ($space eq 'resource') {
- if (defined($Apache::lonhomework::parsing_a_problem) ||
- defined($Apache::lonhomework::parsing_a_task)) {
+ if ( (defined($Apache::lonhomework::parsing_a_problem)
+ || defined($Apache::lonhomework::parsing_a_task))
+ &&
+ ($symbparm eq &symbread()) ) {
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 +4449,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 +4463,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 +4491,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 +4502,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 '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
@@ -4282,9 +4530,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 +4550,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("<font color=blue>WARNING:".
- " Trying to get resource data for ".
- $uname." at ".$udom.": ".
- $tmp."</font>");
- } 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 +4585,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 +4594,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 +4618,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 +4826,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 +4861,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 +4913,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 +4925,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 +4933,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 +4954,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 +4972,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 +5009,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 +5018,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 +5070,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 +5100,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 +5132,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 +5157,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 +5168,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 +5182,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 +5245,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 +5257,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 +5460,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 +5471,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 +5488,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 +5602,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'};
@@ -5428,6 +5652,9 @@ sub filelocation {
if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
+ } elsif ($file=~m:^/home/[^/]*/public_html/:) {
+ # is a correct contruction space reference
+ $location = $file;
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);
@@ -5664,19 +5891,26 @@ BEGIN {
}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
- #&get_iphost();
+ &get_iphost();
}
sub get_iphost {
if (%iphost) { return %iphost; }
+ my %name_to_ip;
foreach my $id (keys(%hostname)) {
my $name=$hostname{$id};
- my $ip = gethostbyname($name);
- if (!$ip || length($ip) ne 4) {
- &logthis("Skipping host $id name $name no IP found\n");
- next;
+ my $ip;
+ if (!exists($name_to_ip{$name})) {
+ $ip = gethostbyname($name);
+ if (!$ip || length($ip) ne 4) {
+ &logthis("Skipping host $id name $name no IP found\n");
+ next;
+ }
+ $ip=inet_ntoa($ip);
+ $name_to_ip{$name} = $ip;
+ } else {
+ $ip = $name_to_ip{$name};
}
- $ip=inet_ntoa($ip);
push(@{$iphost{$ip}},$id);
}
return %iphost;
@@ -5933,14 +6167,14 @@ that was requested
X<appenv()>
B<appenv(%hash)>: 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<delenv()>
B<delenv($regexp)>: 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 +6387,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 +6486,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 +6517,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 +6551,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 +6780,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 +6812,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