--- loncom/lonnet/perl/lonnet.pm 2005/04/07 06:56:24 1.620
+++ loncom/lonnet/perl/lonnet.pm 2005/10/28 21:51:50 1.670
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.620 2005/04/07 06:56:24 albertel Exp $
+# $Id: lonnet.pm,v 1.670 2005/10/28 21:51:50 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -37,7 +37,7 @@ use HTTP::Date;
use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab
- %courselogs %accesshash %userrolehash $processmarker $dumpcount
+ %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
%domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit
@@ -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);
@@ -270,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) {
@@ -278,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);
@@ -296,7 +295,6 @@ sub appenv {
.'');
delete($newenv{$_});
} else {
- $ENV{$_}=$newenv{$_};
$env{$_}=$newenv{$_};
}
}
@@ -384,7 +382,6 @@ sub delenv {
foreach (@oldenv) {
if ($_=~/^$delthis/) {
my ($key,undef) = split('=',$_);
- delete($ENV{$key});
delete($env{$key});
} else {
print $fh $_;
@@ -446,15 +443,15 @@ sub overloaderror {
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
- my ($loadpercent,$userloadpercent) = @_;
+ my ($loadpercent,$userloadpercent,$want_server_name) = @_;
my $tryserver;
my $spareserver='';
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowestserver=$loadpercent > $userloadpercent?
$loadpercent : $userloadpercent;
- foreach $tryserver (keys %spareid) {
- my $loadans=reply('load',$tryserver);
- my $userloadans=reply('userload',$tryserver);
+ foreach $tryserver (keys(%spareid)) {
+ my $loadans=&reply('load',$tryserver);
+ my $userloadans=&reply('userload',$tryserver);
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
next; #didn't get a number from the server
}
@@ -471,7 +468,11 @@ sub spareserver {
$answer = $userloadans;
}
if (($answer =~ /\d/) && ($answer<$lowestserver)) {
- $spareserver="http://$hostname{$tryserver}";
+ if ($want_server_name) {
+ $spareserver=$tryserver;
+ } else {
+ $spareserver="http://$hostname{$tryserver}";
+ }
$lowestserver=$answer;
}
}
@@ -770,6 +771,13 @@ sub validate_access_key {
}
# ------------------------------------- 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)=@_;
@@ -831,8 +839,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;
@@ -879,6 +890,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
@@ -1129,8 +1143,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)
#
@@ -1153,30 +1170,21 @@ sub allowuploaded {
# /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';
@@ -1185,30 +1193,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};
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
@@ -1231,7 +1284,7 @@ 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'};
$fname=&clean_filename($fname);
@@ -1255,30 +1308,30 @@ sub userfileupload {
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);
+ 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);
@@ -1301,8 +1354,17 @@ sub finishuserfileupload {
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') {
#
@@ -1315,6 +1377,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);
@@ -1443,6 +1613,31 @@ sub flushcourselogs {
delete $userrolehash{$entry};
}
}
+#
+# Reverse lookup of domain roles (dc, ad, li, sc, au)
+#
+ my %domrolebuffer = ();
+ foreach my $entry (keys %domainrolehash) {
+ my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
+ if ($domrolebuffer{$rudom}) {
+ $domrolebuffer{$rudom}.='&'.&escape($entry).
+ '='.&escape($domainrolehash{$entry});
+ } else {
+ $domrolebuffer{$rudom}.=&escape($entry).
+ '='.&escape($domainrolehash{$entry});
+ }
+ delete $domainrolehash{$entry};
+ }
+ foreach my $dom (keys(%domrolebuffer)) {
+ foreach my $tryserver (keys %libserv) {
+ if ($hostdom{$tryserver} eq $dom) {
+ unless (&reply('domroleput:'.$dom.':'.
+ $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
+ }
+ }
+ }
+ }
$dumpcount++;
}
@@ -1476,7 +1671,7 @@ sub courseacclog {
my $fnsymb=shift;
unless ($env{'request.course.id'}) { return ''; }
my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
- if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
+ if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
$what.=':POST';
# FIXME: Probably ought to escape things....
foreach (keys %env) {
@@ -1518,14 +1713,24 @@ sub linklog {
sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
- if (($trole=~/^ca/) || ($trole=~/^in/) ||
- ($trole=~/^cc/) || ($trole=~/^ep/) ||
- ($trole=~/^cr/) || ($trole=~/^ta/)) {
+ if (($trole=~/^ca/) || ($trole=~/^aa/) ||
+ ($trole=~/^in/) || ($trole=~/^cc/) ||
+ ($trole=~/^ep/) || ($trole=~/^cr/) ||
+ ($trole=~/^ta/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;
- }
+ }
+ if (($trole=~/^dc/) || ($trole=~/^ad/) ||
+ ($trole=~/^li/) || ($trole=~/^li/) ||
+ ($trole=~/^au/) || ($trole=~/^dg/) ||
+ ($trole=~/^sc/)) {
+ my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
+ $domainrolehash
+ {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
+ = $tend.':'.$tstart;
+ }
}
sub get_course_adv_roles {
@@ -1549,7 +1754,11 @@ sub get_course_adv_roles {
if ($username eq '' || $domain eq '') { next; }
if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }
+ if ($role eq 'cr') { next; }
my $key=&plaintext($role);
+ if ($role =~ /^cr/) {
+ $key=(split('/',$role))[3];
+ }
if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
@@ -1618,7 +1827,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) {
@@ -1627,7 +1836,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)) {
@@ -1640,7 +1849,65 @@ sub courseiddump {
return %returnhash;
}
-#
+# ---------------------------------------------------------- DC e-mail
+
+sub dcmailput {
+ my ($domain,$msgid,$contents,$server)=@_;
+ my $status = &Apache::lonnet::critical(
+ 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
+ &Apache::lonnet::escape($$contents{$server}),$server);
+ return $status;
+}
+
+sub dcmaildump {
+ my ($dom,$startdate,$enddate,$senders) = @_;
+ my %returnhash=();
+ foreach my $tryserver (keys(%libserv)) {
+ if ($hostdom{$tryserver} eq $dom) {
+ %{$returnhash{$tryserver}}=();
+ my $cmd='dcmaildump:'.$dom.':'.
+ &escape($startdate).':'.&escape($enddate).':';
+ my @esc_senders=map { &escape($_)} @$senders;
+ $cmd.=&escape(join('&',@esc_senders));
+ foreach (split(/\&/,&reply($cmd,$tryserver))) {
+ my ($key,$value) = split(/\=/,$_);
+ if (($key) && ($value)) {
+ $returnhash{$tryserver}{&unescape($key)} = &unescape($value);
+ }
+ }
+ }
+ }
+ return %returnhash;
+}
+# ---------------------------------------------------------- Domain roles
+
+sub get_domain_roles {
+ my ($dom,$roles,$startdate,$enddate)=@_;
+ if (undef($startdate) || $startdate eq '') {
+ $startdate = '.';
+ }
+ if (undef($enddate) || $enddate eq '') {
+ $enddate = '.';
+ }
+ my $rolelist = join(':',@{$roles});
+ my %personnel = ();
+ foreach my $tryserver (keys(%libserv)) {
+ if ($hostdom{$tryserver} eq $dom) {
+ %{$personnel{$tryserver}}=();
+ foreach (
+ split(/\&/,&reply('domrolesdump:'.$dom.':'.
+ &escape($startdate).':'.&escape($enddate).':'.
+ &escape($rolelist), $tryserver))) {
+ my($key,$value) = split(/\=/,$_);
+ if (($key) && ($value)) {
+ $personnel{$tryserver}{&unescape($key)} = &unescape($value);
+ }
+ }
+ }
+ }
+ return %personnel;
+}
+
# ----------------------------------------------------------- Check out an item
sub get_first_access {
@@ -2315,11 +2582,14 @@ sub rolesinit {
if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;
-
my ($trole,$tend,$tstart);
if ($role=~/^cr/) {
- ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
- ($tend,$tstart)=split('_',$trest);
+ if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
+ ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
+ ($tend,$tstart)=split('_',$trest);
+ } else {
+ $trole=$role;
+ }
} else {
($trole,$tend,$tstart)=split(/_/,$role);
}
@@ -2335,7 +2605,7 @@ sub rolesinit {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}
}
- }
+ }
}
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
$userroles.='user.adv='.$adv."\n".
@@ -2562,10 +2832,16 @@ sub convert_dump_to_currentdump{
return \%returnhash;
}
+# ------------------------------------------------------ critical inc interface
+
+sub cinc {
+ return &inc(@_,'critical');
+}
+
# --------------------------------------------------------------- inc interface
sub inc {
- my ($namespace,$store,$udomain,$uname) = @_;
+ my ($namespace,$store,$udomain,$uname,$critical) = @_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
@@ -2583,7 +2859,11 @@ 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
@@ -2601,8 +2881,23 @@ 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'}; }
@@ -2663,6 +2958,29 @@ sub eget {
return %returnhash;
}
+# ------------------------------------------------------------ tmpput interface
+sub tmpput {
+ my ($storehash,$server)=@_;
+ my $items='';
+ foreach (keys(%$storehash)) {
+ $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ }
+ $items=~s/\&$//;
+ return &reply("tmpput:$items",$server);
+}
+
+# ------------------------------------------------------------ tmpget interface
+sub tmpget {
+ my ($token)=@_;
+ my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});
+ my %returnhash;
+ foreach my $item (split(/\&/,$rep)) {
+ my ($key,$value)=split(/=/,$item);
+ $returnhash{&unescape($key)}=&thaw_unescape($value);
+ }
+ return %returnhash;
+}
+
# ---------------------------------------------- Custom access rule evaluation
sub customaccess {
@@ -2716,7 +3034,7 @@ 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) &&
+ if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
return 'F';
}
@@ -2784,14 +3102,23 @@ sub allowed {
$thisallowed.=$1;
}
-# URI is an uploaded document for this course
+# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
+ $thisallowed='';
my $refuri=$env{'httpref.'.$orguri};
if ($refuri) {
if ($refuri =~ m|^/adm/|) {
$thisallowed='F';
+ } else {
+ $refuri=&declutter($refuri);
+ my ($match) = &is_on_map($refuri);
+ if ($match) {
+ $thisallowed='F';
+ }
}
+ } else {
+ $thisallowed='';
}
}
@@ -2803,7 +3130,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;
}
#
@@ -2999,8 +3335,7 @@ sub allowed {
# --------------------------------------------------- Is a resource on the map?
sub is_on_map {
- my $uri=&declutter(shift);
- $uri=~s/\.\d+\.(\w+)$/\.$1/;
+ my $uri=&deversion(&declutter(shift));
my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
@@ -3370,7 +3705,7 @@ sub assignrole {
my $answer=&reply($command,&homeserver($uname,$udom));
# log new user role if status is ok
if ($answer eq 'ok') {
- &userrolelog($mrole,$uname,$udom,$url,$start,$end);
+ &userrolelog($role,$uname,$udom,$url,$start,$end);
}
return $answer;
}
@@ -3573,6 +3908,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;
@@ -3677,7 +4014,7 @@ sub createcourse {
ENDINITMAP
$topurl=&declutter(
- &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
+ &finishuserfileupload($uname,$udom,'initmap','default.sequence')
);
}
# ----------------------------------------------------------- Write preferences
@@ -3744,7 +4081,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);
}
@@ -3823,17 +4159,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);
@@ -3868,30 +4208,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});
}
}
}
@@ -4086,13 +4430,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) {
@@ -4104,6 +4449,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};
@@ -4134,7 +4527,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
@@ -4170,8 +4563,10 @@ 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;
@@ -4289,44 +4684,20 @@ 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
@@ -4358,9 +4729,10 @@ 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));
+ my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
+ $env{'course.'.$courseid.'.domain'},
+ 'course',
+ ($courselevelm,$courselevel));
if (defined($coursereply)) { return $coursereply; }
}
# ------------------------------------------------------------------ Cascade up
@@ -4588,7 +4960,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,
@@ -4624,7 +4995,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};
@@ -4676,7 +5047,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;
}
@@ -4781,7 +5152,7 @@ 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) {
@@ -4920,7 +5291,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;
@@ -4930,8 +5302,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);
}
}
}
@@ -4945,7 +5317,6 @@ sub symbread {
}
if ($syval) {
return $env{$cache_str}=$syval;
- #return $env{$cache_str}=&symbclean($syval.'___'.$thisfn);
}
}
&appenv('request.ambiguous' => $thisfn);
@@ -5415,6 +5786,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)/+([^/]+)/+([^/]+)/+(.*)$-);
@@ -5447,14 +5821,15 @@ sub filelocation {
sub hreflocation {
my ($dir,$file)=@_;
unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
- my $finalpath=filelocation($dir,$file);
- $finalpath=~s-^/home/httpd/html--;
- $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;
- return $finalpath;
- } elsif ($file=~m-^/home-) {
- $file=~s-^/home/httpd/html--;
+ $file=filelocation($dir,$file);
+ }
+ if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
+ $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
+ } elsif ($file=~m-/home/(\w+)/public_html/-) {
$file=~s-^/home/(\w+)/public_html/-/~$1/-;
- return $file;
+ } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
+ $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
+ -/uploaded/$1/$2/-x;
}
return $file;
}
@@ -5656,14 +6031,21 @@ BEGIN {
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;
@@ -6140,13 +6522,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
@@ -6561,7 +6947,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