--- loncom/lonnet/perl/lonnet.pm 2007/09/05 17:37:51 1.910
+++ loncom/lonnet/perl/lonnet.pm 2008/07/17 21:22:51 1.963
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.910 2007/09/05 17:37:51 albertel Exp $
+# $Id: lonnet.pm,v 1.963 2008/07/17 21:22:51 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -39,7 +39,7 @@ use vars qw(%perlvar %spareid %pr %prp $
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
- %courseownerbuf, %coursetypebuf);
+ %courseownerbuf, %coursetypebuf,$locknum);
use IO::Socket;
use GDBM_File;
@@ -88,24 +88,26 @@ delayed.
{
my $logid;
sub instructor_log {
- my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
+ my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
+ if (($cnum eq '') || ($cdom eq '')) {
+ $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ }
$logid++;
- my $id=time().'00000'.$$.'00000'.$logid;
+ my $now = time();
+ my $id=$now.'00000'.$$.'00000'.$logid;
return &Apache::lonnet::put('nohist_'.$hash_name,
{ $id => {
'exe_uname' => $env{'user.name'},
'exe_udom' => $env{'user.domain'},
- 'exe_time' => time(),
+ 'exe_time' => $now,
'exe_ip' => $ENV{'REMOTE_ADDR'},
'delflag' => $delflag,
'logentry' => $storehash,
'uname' => $uname,
'udom' => $udom,
}
- },
- $env{'course.'.$env{'request.course.id'}.'.domain'},
- $env{'course.'.$env{'request.course.id'}.'.num'}
- );
+ },$cdom,$cnum);
}
}
@@ -320,7 +322,10 @@ sub convert_and_load_session_env {
my ($lonidsdir,$handle)=@_;
my @profile;
{
- open(my $idf,"$lonidsdir/$handle.id");
+ my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
+ if (!$opened) {
+ return 0;
+ }
flock($idf,LOCK_SH);
@profile=<$idf>;
close($idf);
@@ -359,7 +364,10 @@ sub transfer_profile_to_env {
my $convert;
{
- open(my $idf,"$lonidsdir/$handle.id");
+ my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
+ if (!$opened) {
+ return;
+ }
flock($idf,LOCK_SH);
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
&GDBM_READER(),0640)) {
@@ -391,6 +399,34 @@ sub transfer_profile_to_env {
}
}
+# ---------------------------------------------------- Check for valid session
+sub check_for_valid_session {
+ my ($r) = @_;
+ my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
+ my $lonid=$cookies{'lonID'};
+ return undef if (!$lonid);
+
+ my $handle=&LONCAPA::clean_handle($lonid->value);
+ my $lonidsdir=$r->dir_config('lonIDsDir');
+ return undef if (!-e "$lonidsdir/$handle.id");
+
+ my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
+ return undef if (!$opened);
+
+ flock($idf,LOCK_SH);
+ my %disk_env;
+ if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
+ &GDBM_READER(),0640)) {
+ return undef;
+ }
+
+ if (!defined($disk_env{'user.name'})
+ || !defined($disk_env{'user.domain'})) {
+ return undef;
+ }
+ return $handle;
+}
+
sub timed_flock {
my ($file,$lock_type) = @_;
my $failed=0;
@@ -414,26 +450,39 @@ sub timed_flock {
# ---------------------------------------------------------- Append Environment
sub appenv {
- my %newenv=@_;
- foreach my $key (keys(%newenv)) {
- if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
- &logthis("WARNING: ".
- "Attempt to modify environment ".$key." to ".$newenv{$key}
- .'');
- delete($newenv{$key});
- } else {
- $env{$key}=$newenv{$key};
+ my ($newenv,$roles) = @_;
+ if (ref($newenv) eq 'HASH') {
+ foreach my $key (keys(%{$newenv})) {
+ my $refused = 0;
+ if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
+ $refused = 1;
+ if (ref($roles) eq 'ARRAY') {
+ my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
+ if (grep(/^\Q$role\E$/,@{$roles})) {
+ $refused = 0;
+ }
+ }
+ }
+ if ($refused) {
+ &logthis("WARNING: ".
+ "Attempt to modify environment ".$key." to ".$newenv->{$key}
+ .'');
+ delete($newenv->{$key});
+ } else {
+ $env{$key}=$newenv->{$key};
+ }
+ }
+ my $opened = open(my $env_file,'+<',$env{'user.environment'});
+ if ($opened
+ && &timed_flock($env_file,LOCK_EX)
+ &&
+ tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+ (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
+ while (my ($key,$value) = each(%{$newenv})) {
+ $disk_env{$key} = $value;
+ }
+ untie(%disk_env);
}
- }
- open(my $env_file,$env{'user.environment'});
- if (&timed_flock($env_file,LOCK_EX)
- &&
- tie(my %disk_env,'GDBM_File',$env{'user.environment'},
- (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
- while (my ($key,$value) = each(%newenv)) {
- $disk_env{$key} = $value;
- }
- untie(%disk_env);
}
return 'ok';
}
@@ -446,16 +495,17 @@ sub delenv {
"Attempt to delete from environment ".$delthis);
return 'error';
}
- open(my $env_file,$env{'user.environment'});
- if (&timed_flock($env_file,LOCK_EX)
+ my $opened = open(my $env_file,'+<',$env{'user.environment'});
+ if ($opened
+ && &timed_flock($env_file,LOCK_EX)
&&
tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
foreach my $key (keys(%disk_env)) {
if ($key=~/^$delthis/) {
- delete($env{$key});
- delete($disk_env{$key});
- }
+ delete($env{$key});
+ delete($disk_env{$key});
+ }
}
untie(%disk_env);
}
@@ -476,8 +526,52 @@ sub get_env_multiple {
return(@values);
}
+# ------------------------------------------------------------------- Locking
+
+sub set_lock {
+ my ($text)=@_;
+ $locknum++;
+ my $id=$$.'-'.$locknum;
+ &appenv({'session.locks' => $env{'session.locks'}.','.$id,
+ 'session.lock.'.$id => $text});
+ return $id;
+}
+
+sub get_locks {
+ my $num=0;
+ my %texts=();
+ foreach my $lock (split(/\,/,$env{'session.locks'})) {
+ if ($lock=~/\w/) {
+ $num++;
+ $texts{$lock}=$env{'session.lock.'.$lock};
+ }
+ }
+ return ($num,%texts);
+}
+
+sub remove_lock {
+ my ($id)=@_;
+ my $newlocks='';
+ foreach my $lock (split(/\,/,$env{'session.locks'})) {
+ if (($lock=~/\w/) && ($lock ne $id)) {
+ $newlocks.=','.$lock;
+ }
+ }
+ &appenv({'session.locks' => $newlocks});
+ &delenv('session.lock.'.$id);
+}
+
+sub remove_all_locks {
+ my $activelocks=$env{'session.locks'};
+ foreach my $lock (split(/\,/,$env{'session.locks'})) {
+ if ($lock=~/\w/) {
+ &remove_lock($lock);
+ }
+ }
+}
+
+
# ------------------------------------------ Find out current server userload
-# there is a copy in lond
sub userload {
my $numusers=0;
{
@@ -485,7 +579,8 @@ sub userload {
my $filename;
my $curtime=time;
while ($filename=readdir(LONIDS)) {
- if ($filename eq '.' || $filename eq '..') {next;}
+ next if ($filename eq '.' || $filename eq '..');
+ next if ($filename =~ /publicuser_\d+\.id/);
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }
}
@@ -582,6 +677,27 @@ sub compare_server_load {
}
return ($spare_server,$lowest_load);
}
+
+# --------------------------- ask offload servers if user already has a session
+sub find_existing_session {
+ my ($udom,$uname) = @_;
+ foreach my $try_server (@{ $spareid{'primary'} },
+ @{ $spareid{'default'} }) {
+ return $try_server if (&has_user_session($try_server, $udom, $uname));
+ }
+ return;
+}
+
+# -------------------------------- ask if server already has a session for user
+sub has_user_session {
+ my ($lonid,$udom,$uname) = @_;
+ my $result = &reply(join(':','userhassession',
+ map {&escape($_)} ($udom,$uname)),$lonid);
+ return 1 if ($result eq 'ok');
+
+ return 0;
+}
+
# --------------------------------------------- Try to change a user's password
sub changepass {
@@ -636,24 +752,38 @@ sub queryauthenticate {
# --------- Try to authenticate user from domain's lib servers (first this one)
sub authenticate {
- my ($uname,$upass,$udom)=@_;
+ my ($uname,$upass,$udom,$checkdefauth)=@_;
$upass=&escape($upass);
$uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom,1);
+ my $newhome;
if ((!$uhome) || ($uhome eq 'no_host')) {
# Maybe the machine was offline and only re-appeared again recently?
&reconlonc();
# One more
- my $uhome=&homeserver($uname,$udom,1);
+ $uhome=&homeserver($uname,$udom,1);
+ if (($uhome eq 'no_host') && $checkdefauth) {
+ if (defined(&domain($udom,'primary'))) {
+ $newhome=&domain($udom,'primary');
+ }
+ if ($newhome ne '') {
+ $uhome = $newhome;
+ }
+ }
if ((!$uhome) || ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown in authenticate");
- }
- return 'no_host';
+ return 'no_host';
+ }
}
- my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
+ my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
if ($answer eq 'authorized') {
- &logthis("User $uname at $udom authorized by $uhome");
- return $uhome;
+ if ($newhome) {
+ &logthis("User $uname at $udom authorized by $uhome, but needs account");
+ return 'no_account_on_host';
+ } else {
+ &logthis("User $uname at $udom authorized by $uhome");
+ return $uhome;
+ }
}
if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $uhome");
@@ -828,6 +958,10 @@ sub retrieve_inst_usertypes {
if (defined(&domain($udom,'primary'))) {
my $uhome=&domain($udom,'primary');
my $rep=&reply("inst_usertypes:$udom",$uhome);
+ if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
+ &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
+ return (\%returnhash,\@order);
+ }
my ($hashitems,$orderitems) = split(/:/,$rep);
my @pairs=split(/\&/,$hashitems);
foreach my $item (@pairs) {
@@ -906,8 +1040,8 @@ sub usersearch {
if (&host_domain($tryserver) eq $dom) {
my $host=&hostname($tryserver);
my $queryid=
- &reply("querysend:".&escape($query).':'.&escape($dom).':'.
- &escape($srch->{'srchby'}).'%%'.
+ &reply("querysend:".&escape($query).':'.
+ &escape($srch->{'srchby'}).':'.
&escape($srch->{'srchtype'}).':'.
&escape($srch->{'srchterm'}),$tryserver);
if ($queryid !~/^\Q$host\E\_/) {
@@ -924,20 +1058,23 @@ sub usersearch {
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
&logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries);
} else {
- my @matches = split(/&/,$reply);
+ my @matches;
+ if ($reply =~ /\n/) {
+ @matches = split(/\n/,$reply);
+ } else {
+ @matches = split(/\&/,$reply);
+ }
foreach my $match (@matches) {
- my @items = split(/:/,$match);
my ($uname,$udom,%userhash);
- foreach my $entry (@items) {
- my ($key,$value) = split(/=/,$entry);
- $key = &unescape($key);
- $value = &unescape($value);
+ foreach my $entry (split(/:/,$match)) {
+ my ($key,$value) =
+ map {&unescape($_);} split(/=/,$entry);
$userhash{$key} = $value;
if ($key eq 'username') {
$uname = $value;
} elsif ($key eq 'domain') {
$udom = $value;
- }
+ }
}
$results{$uname.':'.$udom} = \%userhash;
}
@@ -947,6 +1084,150 @@ sub usersearch {
return %results;
}
+sub get_instuser {
+ my ($udom,$uname,$id) = @_;
+ my $homeserver = &domain($udom,'primary');
+ my ($outcome,%results);
+ if ($homeserver ne '') {
+ my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
+ &escape($id).':'.&escape($udom),$homeserver);
+ my $host=&hostname($homeserver);
+ if ($queryid !~/^\Q$host\E\_/) {
+ &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
+ return;
+ }
+ my $response = &get_query_reply($queryid);
+ my $maxtries = 5;
+ my $tries = 1;
+ while (($response=~/^timeout/) && ($tries < $maxtries)) {
+ $response = &get_query_reply($queryid);
+ $tries ++;
+ }
+ if (!&error($response) && $response ne 'refused') {
+ if ($response eq 'unavailable') {
+ $outcome = $response;
+ } else {
+ $outcome = 'ok';
+ my @matches = split(/\n/,$response);
+ foreach my $match (@matches) {
+ my ($key,$value) = split(/=/,$match);
+ $results{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
+ }
+ my %userinfo;
+ if (ref($results{$uname}) eq 'HASH') {
+ %userinfo = %{$results{$uname}};
+ }
+ return ($outcome,%userinfo);
+}
+
+sub inst_rulecheck {
+ my ($udom,$uname,$id,$item,$rules) = @_;
+ my %returnhash;
+ if ($udom ne '') {
+ if (ref($rules) eq 'ARRAY') {
+ @{$rules} = map {&escape($_);} (@{$rules});
+ my $rulestr = join(':',@{$rules});
+ my $homeserver=&domain($udom,'primary');
+ if (($homeserver ne '') && ($homeserver ne 'no_host')) {
+ my $response;
+ if ($item eq 'username') {
+ $response=&unescape(&reply('instrulecheck:'.&escape($udom).
+ ':'.&escape($uname).':'.$rulestr,
+ $homeserver));
+ } elsif ($item eq 'id') {
+ $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
+ ':'.&escape($id).':'.$rulestr,
+ $homeserver));
+ } elsif ($item eq 'selfcreate') {
+ $response=&unescape(&reply('instselfcreatecheck:'.
+ &escape($udom).':'.&escape($uname).
+ ':'.$rulestr,$homeserver));
+ }
+ if ($response ne 'refused') {
+ my @pairs=split(/\&/,$response);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ }
+ }
+ }
+ }
+ return %returnhash;
+}
+
+sub inst_userrules {
+ my ($udom,$check) = @_;
+ my (%ruleshash,@ruleorder);
+ if ($udom ne '') {
+ my $homeserver=&domain($udom,'primary');
+ if (($homeserver ne '') && ($homeserver ne 'no_host')) {
+ my $response;
+ if ($check eq 'id') {
+ $response=&reply('instidrules:'.&escape($udom),
+ $homeserver);
+ } elsif ($check eq 'email') {
+ $response=&reply('instemailrules:'.&escape($udom),
+ $homeserver);
+ } else {
+ $response=&reply('instuserrules:'.&escape($udom),
+ $homeserver);
+ }
+ if (($response ne 'refused') && ($response ne 'error') &&
+ ($response ne 'unknown_cmd') &&
+ ($response ne 'no_such_host')) {
+ my ($hashitems,$orderitems) = split(/:/,$response);
+ my @pairs=split(/\&/,$hashitems);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $ruleshash{$key}=&thaw_unescape($value);
+ }
+ my @esc_order = split(/\&/,$orderitems);
+ foreach my $item (@esc_order) {
+ push(@ruleorder,&unescape($item));
+ }
+ }
+ }
+ }
+ return (\%ruleshash,\@ruleorder);
+}
+
+# ------------------------- Get Authentication and Language Defaults for Domain
+
+sub get_domain_defaults {
+ my ($domain) = @_;
+ my $cachetime = 60*60*24;
+ my ($defauthtype,$defautharg,$deflang);
+ my ($result,$cached)=&is_cached_new('domdefaults',$domain);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ return %{$result};
+ }
+ }
+ my %domdefaults;
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['defaults'],$domain);
+ if (ref($domconfig{'defaults'}) eq 'HASH') {
+ $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
+ $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
+ $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+ } else {
+ $domdefaults{'lang_def'} = &domain($domain,'lang_def');
+ $domdefaults{'auth_def'} = &domain($domain,'auth_def');
+ $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
+ }
+ &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
+ $cachetime);
+ return %domdefaults;
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -979,7 +1260,7 @@ sub assign_access_key {
# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {
- &appenv('environment.'.$envkey => $ckey);
+ &appenv({'environment.'.$envkey => $ckey});
return 'ok';
} else {
return
@@ -1229,13 +1510,15 @@ sub do_cache_new {
$memcache->disconnect_all();
}
# need to make a copy of $value
- #&make_room($id,$value,$debug);
+ &make_room($id,$value,$debug);
return $value;
}
sub make_room {
my ($id,$value,$debug)=@_;
- $remembered{$id}=$value;
+
+ $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
+ : $value;
if ($to_remember<0) { return; }
$accessed{$id}=[&gettimeofday()];
if (scalar(keys(%remembered)) <= $to_remember) { return; }
@@ -1461,12 +1744,21 @@ sub ssi_body {
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
$form{'LONCAPA_INTERNAL_no_discussion'}='true';
}
- my $output=($filelink=~/^http\:/?&externalssi($filelink):
- &ssi($filelink,%form));
+ my $output='';
+ my $response;
+ if ($filelink=~/^http\:/) {
+ ($output,$response)=&externalssi($filelink);
+ } else {
+ ($output,$response)=&ssi($filelink,%form);
+ }
$output=~s|//(\s*)?\s||gs;
$output=~s/^.*?\]*\>//si;
- $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
- return $output;
+ $output=~s/\<\/body\s*\>.*?$//si;
+ if (wantarray) {
+ return ($output, $response);
+ } else {
+ return $output;
+ }
}
# --------------------------------------------------------- Server Side Include
@@ -1480,12 +1772,20 @@ sub absolute_url {
return $protocol.$host_name;
}
+#
+# Server side include.
+# Parameters:
+# fn Possibly encrypted resource name/id.
+# form Hash that describes how the rendering should be done
+# and other things.
+# Returns:
+# Scalar context: The content of the response.
+# Array context: 2 element list of the content and the full response object.
+#
sub ssi {
my ($fn,%form)=@_;
-
my $ua=new LWP::UserAgent;
-
my $request;
$form{'no_update_last_known'}=1;
@@ -1500,7 +1800,11 @@ sub ssi {
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $response=$ua->request($request);
- return $response->content;
+ if (wantarray) {
+ return ($response->content, $response);
+ } else {
+ return $response->content;
+ }
}
sub externalssi {
@@ -1508,7 +1812,11 @@ sub externalssi {
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',$url);
my $response=$ua->request($request);
- return $response->content;
+ if (wantarray) {
+ return ($response->content, $response);
+ } else {
+ return $response->content;
+ }
}
# -------------------------------- Allow a /uploaded/ URI to be vouched for
@@ -1521,7 +1829,7 @@ sub allowuploaded {
my %httpref=();
my $httpurl=&hreflocation('',$url);
$httpref{'httpref.'.$httpurl}=$srcurl;
- &Apache::lonnet::appenv(%httpref);
+ &Apache::lonnet::appenv(\%httpref);
}
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
@@ -1582,7 +1890,7 @@ sub process_coursefile {
print $fh $env{'form.'.$source};
close($fh);
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
+ 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);
}
@@ -1790,7 +2098,7 @@ sub finishuserfileupload {
close(FH);
}
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
+ my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
$codebase);
unless ($parse_result eq 'ok') {
&logthis('Failed to parse '.$filepath.$file.
@@ -1830,7 +2138,7 @@ sub finishuserfileupload {
}
sub extract_embedded_items {
- my ($filepath,$file,$allfiles,$codebase,$content) = @_;
+ my ($fullpath,$allfiles,$codebase,$content) = @_;
my @state = ();
my %javafiles = (
codebase => '',
@@ -1845,7 +2153,7 @@ sub extract_embedded_items {
if ($content) {
$p = HTML::LCParser->new($content);
} else {
- $p = HTML::LCParser->new($filepath.'/'.$file);
+ $p = HTML::LCParser->new($fullpath);
}
while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {
@@ -2016,7 +2324,7 @@ sub flushcourselogs {
# times and course titles for all courseids
#
my %courseidbuffer=();
- foreach my $crsid (keys %courselogs) {
+ foreach my $crsid (keys(%courselogs)) {
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
&escape($courselogs{$crsid}),
$coursehombuf{$crsid}) eq 'ok') {
@@ -2029,23 +2337,21 @@ sub flushcourselogs {
delete $courselogs{$crsid};
}
}
- if ($courseidbuffer{$coursehombuf{$crsid}}) {
- $courseidbuffer{$coursehombuf{$crsid}}.='&'.
- &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
- ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
- } else {
- $courseidbuffer{$coursehombuf{$crsid}}=
- &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
- ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
- }
+ $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
+ 'description' => $coursedescrbuf{$crsid},
+ 'inst_code' => $courseinstcodebuf{$crsid},
+ 'type' => $coursetypebuf{$crsid},
+ 'owner' => $courseownerbuf{$crsid},
+ };
}
#
# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse
#
foreach my $crs_home (keys(%courseidbuffer)) {
- &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},
- $crs_home);
+ my $response = &courseidput(&host_domain($crs_home),
+ $courseidbuffer{$crs_home},
+ $crs_home,'timeonly');
}
#
# File accesses
@@ -2225,13 +2531,47 @@ sub userrolelog {
}
}
+sub courserolelog {
+ my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
+ if (($trole eq 'cc') || ($trole eq 'in') ||
+ ($trole eq 'ep') || ($trole eq 'ad') ||
+ ($trole eq 'ta') || ($trole eq 'st') ||
+ ($trole=~/^cr/) || ($trole eq 'gr')) {
+ if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
+ my $cdom = $1;
+ my $cnum = $2;
+ my $sec = $3;
+ my $namespace = 'rolelog';
+ my %storehash = (
+ role => $trole,
+ start => $tstart,
+ end => $tend,
+ selfenroll => $selfenroll,
+ context => $context,
+ );
+ if ($trole eq 'gr') {
+ $namespace = 'groupslog';
+ $storehash{'group'} = $sec;
+ } else {
+ $storehash{'section'} = $sec;
+ }
+ &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
+ }
+ }
+ return;
+}
+
sub get_course_adv_roles {
- my $cid=shift;
+ my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
my %nothide=();
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
- $nothide{join(':',split(/[\@\:]/,$user))}=1;
+ if ($user !~ /:/) {
+ $nothide{join(':',split(/[\@]/,$user))}=1;
+ } else {
+ $nothide{$user}=1;
+ }
}
my %returnhash=();
my %dumphash=
@@ -2247,27 +2587,46 @@ sub get_course_adv_roles {
if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
- my $key=&plaintext($role);
- if ($section) { $key.=' (Sec/Grp '.$section.')'; }
- if ($returnhash{$key}) {
- $returnhash{$key}.=','.$username.':'.$domain;
+ if ($codes) {
+ if ($section) { $role .= ':'.$section; }
+ if ($returnhash{$role}) {
+ $returnhash{$role}.=','.$username.':'.$domain;
+ } else {
+ $returnhash{$role}=$username.':'.$domain;
+ }
} else {
- $returnhash{$key}=$username.':'.$domain;
+ my $key=&plaintext($role);
+ if ($section) { $key.=' (Section '.$section.')'; }
+ if ($returnhash{$key}) {
+ $returnhash{$key}.=','.$username.':'.$domain;
+ } else {
+ $returnhash{$key}=$username.':'.$domain;
+ }
}
- }
+ }
return %returnhash;
}
sub get_my_roles {
- my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
+ my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }
- my %dumphash;
+ my (%dumphash,%nothide);
if ($context eq 'userroles') {
%dumphash = &dump('roles',$udom,$uname);
} else {
%dumphash=
&dump('nohist_userroles',$udom,$uname);
+ if ($hidepriv) {
+ my %coursehash=&coursedescription($udom.'_'.$uname);
+ foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
+ if ($user !~ /:/) {
+ $nothide{join(':',split(/[\@]/,$user))} = 1;
+ } else {
+ $nothide{$user} = 1;
+ }
+ }
+ }
}
my %returnhash=();
my $now=time;
@@ -2280,7 +2639,7 @@ sub get_my_roles {
}
if (($tstart) && ($tstart<0)) { next; }
my $status = 'active';
- if (($tend) && ($tend<$now)) {
+ if (($tend) && ($tend<=$now)) {
$status = 'previous';
}
if (($tstart) && ($now<$tstart)) {
@@ -2309,10 +2668,27 @@ sub get_my_roles {
}
if (ref($roles) eq 'ARRAY') {
if (!grep(/^\Q$role\E$/,@{$roles})) {
+ if ($role =~ /^cr\//) {
+ if (!grep(/^cr$/,@{$roles})) {
+ next;
+ }
+ } else {
+ next;
+ }
+ }
+ }
+ if ($hidepriv) {
+ if ((&privileged($username,$domain)) &&
+ (!$nothide{$username.':'.$domain})) {
next;
}
}
- $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
+ if ($withsec) {
+ $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
+ $tstart.':'.$tend;
+ } else {
+ $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
+ }
}
return %returnhash;
}
@@ -2351,31 +2727,80 @@ sub getannounce {
#
sub courseidput {
- my ($domain,$what,$coursehome)=@_;
- return &reply('courseidput:'.$domain.':'.$what,$coursehome);
+ my ($domain,$storehash,$coursehome,$caller) = @_;
+ my $outcome;
+ if ($caller eq 'timeonly') {
+ my $cids = '';
+ foreach my $item (keys(%$storehash)) {
+ $cids.=&escape($item).'&';
+ }
+ $cids=~s/\&$//;
+ $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
+ $coursehome);
+ } else {
+ my $items = '';
+ foreach my $item (keys(%$storehash)) {
+ $items.= &escape($item).'='.
+ &freeze_escape($$storehash{$item}).'&';
+ }
+ $items=~s/\&$//;
+ $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
+ $coursehome);
+ }
+ if ($outcome eq 'unknown_cmd') {
+ my $what;
+ foreach my $cid (keys(%$storehash)) {
+ $what .= &escape($cid).'=';
+ foreach my $item ('description','inst_code','owner','type') {
+ $what .= &escape($storehash->{$cid}{$item}).':';
+ }
+ $what =~ s/\:$/&/;
+ }
+ $what =~ s/\&$//;
+ return &reply('courseidput:'.$domain.':'.$what,$coursehome);
+ } else {
+ return $outcome;
+ }
}
sub courseiddump {
- my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
- my %returnhash=();
- unless ($domfilter) { $domfilter=''; }
+ my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
+ $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
+ $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
+ my $as_hash = 1;
+ my %returnhash;
+ if (!$domfilter) { $domfilter=''; }
my %libserv = &all_library();
foreach my $tryserver (keys(%libserv)) {
if ( ( $hostidflag == 1
&& grep(/^\Q$tryserver\E$/,@{$hostidref}) )
|| (!defined($hostidflag)) ) {
- if ($domfilter eq ''
- || (&host_domain($tryserver) eq $domfilter)) {
- foreach my $line (
- split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.
- $sincefilter.':'.&escape($descfilter).':'.
- &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
- $tryserver))) {
- my ($key,$value)=split(/\=/,$line,2);
- if (($key) && ($value)) {
- $returnhash{&unescape($key)}=$value;
- }
+ if (($domfilter eq '') ||
+ (&host_domain($tryserver) eq $domfilter)) {
+ my $rep =
+ &reply('courseiddump:'.&host_domain($tryserver).':'.
+ $sincefilter.':'.&escape($descfilter).':'.
+ &escape($instcodefilter).':'.&escape($ownerfilter).
+ ':'.&escape($coursefilter).':'.&escape($typefilter).
+ ':'.&escape($regexp_ok).':'.$as_hash.':'.
+ &escape($selfenrollonly).':'.&escape($catfilter).':'.
+ $showhidden.':'.$caller,$tryserver);
+ my @pairs=split(/\&/,$rep);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/\=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ my $result = &thaw_unescape($value);
+ if (ref($result) eq 'HASH') {
+ $returnhash{$key}=$result;
+ } else {
+ my @responses = split(/:/,$value);
+ my @items = ('description','inst_code','owner','type');
+ for (my $i=0; $i<@responses; $i++) {
+ $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
+ }
+ }
}
}
}
@@ -2421,7 +2846,10 @@ sub get_domain_roles {
if (undef($enddate) || $enddate eq '') {
$enddate = '.';
}
- my $rolelist = join(':',@{$roles});
+ my $rolelist;
+ if (ref($roles) eq 'ARRAY') {
+ $rolelist = join(':',@{$roles});
+ }
my %personnel = ();
my %servers = &get_servers($dom,'library');
@@ -2447,7 +2875,9 @@ sub get_first_access {
my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);
- if ($type eq 'map') {
+ if ($type eq 'course') {
+ $res='course';
+ } elsif ($type eq 'map') {
$res=&symbread($map);
} else {
$res=$symb;
@@ -2460,7 +2890,9 @@ sub set_first_access {
my ($type)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();
my ($map,$id,$res)=&decode_symb($symb);
- if ($type eq 'map') {
+ if ($type eq 'course') {
+ $res='course';
+ } elsif ($type eq 'map') {
$res=&symbread($map);
} else {
$res=$symb;
@@ -3090,7 +3522,7 @@ sub coursedescription {
}
}
if (!$args->{'one_time'}) {
- &appenv(%envhash);
+ &appenv(\%envhash);
}
return %returnhash;
}
@@ -3275,7 +3707,7 @@ sub set_userprivs {
}
foreach my $role (keys(%{$allroles})) {
my %thesepriv;
- if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
+ if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
foreach my $item (split(/:/,$$allroles{$role})) {
if ($item ne '') {
my ($privilege,$restrictions)=split(/&/,$item);
@@ -3639,6 +4071,7 @@ sub tmpget {
my %returnhash;
foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);
+ next if ($key =~ /^error: 2 /);
$returnhash{&unescape($key)}=&thaw_unescape($value);
}
return %returnhash;
@@ -4106,7 +4539,6 @@ sub allowed {
}
# Full access at system, domain or course-wide level? Exit.
-
if ($thisallowed=~/F/) {
return 'F';
}
@@ -4616,8 +5048,15 @@ sub auto_run {
$response = 1;
}
} else {
- my $homeserver = &homeserver($cnum,$cdom);
- $response = &reply('autorun:'.$cdom,$homeserver);
+ my $homeserver;
+ if (&is_course($cdom,$cnum)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ } else {
+ $homeserver = &domain($cdom,'primary');
+ }
+ if ($homeserver ne 'no_host') {
+ $response = &reply('autorun:'.$cdom,$homeserver);
+ }
}
return $response;
}
@@ -4821,10 +5260,16 @@ sub auto_instcode_defaults {
}
sub auto_validate_class_sec {
- my ($cdom,$cnum,$owner,$inst_class) = @_;
+ my ($cdom,$cnum,$owners,$inst_class) = @_;
my $homeserver = &homeserver($cnum,$cdom);
+ my $ownerlist;
+ if (ref($owners) eq 'ARRAY') {
+ $ownerlist = join(',',@{$owners});
+ } else {
+ $ownerlist = $owners;
+ }
my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
- &escape($owner).':'.$cdom,$homeserver);
+ &escape($ownerlist).':'.$cdom,$homeserver);
return $response;
}
@@ -4872,11 +5317,11 @@ sub toggle_coursegroup_status {
}
sub modify_group_roles {
- my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
+ my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
my $role = 'gr/'.&escape($userprivs);
my ($uname,$udom) = split(/:/,$user);
- my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+ my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}
@@ -4992,7 +5437,8 @@ sub plaintext {
# ----------------------------------------------------------------- Assign Role
sub assignrole {
- my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
+ my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
+ $context)=@_;
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
@@ -5017,11 +5463,25 @@ sub assignrole {
} else {
my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
- 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'});
- return 'refused';
+ if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
+ my $refused;
+ if (($env{'request.course.sec'} ne '') && ($role eq 'st')) {
+ if (!(&allowed('c'.$role,$url))) {
+ $refused = 1;
+ }
+ } else {
+ $refused = 1;
+ }
+ if ($refused) {
+ if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ $refused = '';
+ } else {
+ &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
+ ' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
+ }
}
$mrole=$role;
}
@@ -5037,6 +5497,7 @@ sub assignrole {
}
my $origstart = $start;
my $origend = $end;
+ my $delflag;
# actually delete
if ($deleteflag) {
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
@@ -5047,6 +5508,7 @@ sub assignrole {
# set start and finish to negative values for userrolelog
$start=-1;
$end=-1;
+ $delflag = 1;
}
}
# send command
@@ -5055,9 +5517,10 @@ sub assignrole {
if ($answer eq 'ok') {
&userrolelog($role,$uname,$udom,$url,$start,$end);
# for course roles, perform group memberships changes triggered by role change.
+ &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
unless ($role =~ /^gr/) {
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
- $origstart);
+ $origstart,$selfenroll,$context);
}
}
return $answer;
@@ -5095,7 +5558,7 @@ sub modifyuser {
my ($udom, $uname, $uid,
$umode, $upass, $first,
$middle, $last, $gene,
- $forceid, $desiredhome, $email)=@_;
+ $forceid, $desiredhome, $email, $inststatus)=@_;
$udom= &LONCAPA::clean_domain($udom);
$uname=&LONCAPA::clean_username($uname);
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
@@ -5156,7 +5619,7 @@ sub modifyuser {
# -------------------------------------------------------------- Add names, etc
my @tmp=&get('environment',
['firstname','middlename','lastname','generation','id',
- 'permanentemail'],
+ 'permanentemail','inststatus'],
$udom,$uname);
my %names;
if ($tmp[0] =~ m/^error:.*/) {
@@ -5174,19 +5637,23 @@ sub modifyuser {
if (defined($gene)) { $names{'generation'} = $gene; }
if ($email) {
$email=~s/[^\w\@\.\-\,]//gs;
- if ($email=~/\@/) { $names{'notification'} = $email;
- $names{'critnotification'} = $email;
- $names{'permanentemail'} = $email; }
+ if ($email=~/\@/) { $names{'permanentemail'} = $email; }
}
if ($uid) { $names{'id'} = $uid; }
+ if (defined($inststatus)) { $names{'inststatus'} = $inststatus; }
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);
- &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
- $umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.' by '.
- $env{'user.name'}.' at '.$env{'user.domain'});
+ my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
+ $umode.', '.$first.', '.$middle.', '.
+ $last.', '.$gene.', '.$email.', '.$inststatus;
+ if ($env{'user.name'} ne '' && $env{'user.domain'}) {
+ $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
+ } else {
+ $logmsg .= ' during self creation';
+ }
+ &logthis($logmsg);
return 'ok';
}
@@ -5194,7 +5661,8 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
- $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
+ $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
+ $selfenroll,$context)=@_;
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';
@@ -5209,12 +5677,12 @@ sub modifystudent {
# students environment
$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
- $gene,$usec,$end,$start,$type,$locktype,$cid);
+ $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
return $reply;
}
sub modify_student_enrollment {
- my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
+ my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
my ($cdom,$cnum,$chome);
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
@@ -5272,7 +5740,7 @@ sub modify_student_enrollment {
if ($usec) {
$uurl.='/'.$usec;
}
- return &assignrole($udom,$uname,$uurl,'st',$end,$start);
+ return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
}
sub format_name {
@@ -5353,10 +5821,15 @@ sub createcourse {
}
# ----------------------------------------------------------------- Course made
# log existence
- &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
- ':'.&escape($inst_code).':'.&escape($course_owner).':'.
- &escape($crstype),$uhome);
- &flushcourselogs();
+ my $newcourse = {
+ $udom.'_'.$uname => {
+ description => $description,
+ inst_code => $inst_code,
+ owner => $course_owner,
+ type => $crstype,
+ },
+ };
+ &courseidput($udom,$newcourse,$uhome,'notime');
# set toplevel url
my $topurl=$url;
unless ($nonstandard) {
@@ -5396,33 +5869,41 @@ sub is_course {
# ---------------------------------------------------------- Assign Custom Role
sub assigncustomrole {
- my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
+ my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
- $end,$start,$deleteflag);
+ $end,$start,$deleteflag,$selfenroll,$context);
}
# ----------------------------------------------------------------- Revoke Role
sub revokerole {
- my ($udom,$uname,$url,$role,$deleteflag)=@_;
+ my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
my $now=time;
- return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
+ return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context);
}
# ---------------------------------------------------------- Revoke Custom Role
sub revokecustomrole {
- my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
+ my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
my $now=time;
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
- $deleteflag);
+ $deleteflag,$selfenroll,$context);
}
# ------------------------------------------------------------ Disk usage
sub diskusage {
- my ($udom,$uname,$directoryRoot)=@_;
- $directoryRoot =~ s/\/$//;
- my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
+ my ($udom,$uname,$directorypath,$getpropath)=@_;
+ $directorypath =~ s/\/$//;
+ my $listing=&reply('du2:'.&escape($directorypath).':'
+ .&escape($getpropath).':'.&escape($uname).':'
+ .&escape($udom),homeserver($uname,$udom));
+ if ($listing eq 'unknown_cmd') {
+ if ($getpropath) {
+ $directorypath = &propath($udom,$uname).'/'.$directorypath;
+ }
+ $listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
+ }
return $listing;
}
@@ -5839,30 +6320,49 @@ sub unmark_as_readonly {
# ------------------------------------------------------------ Directory lister
sub dirlist {
- my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
-
+ my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;
$uri=~s/^\///;
$uri=~s/\/$//;
my ($udom, $uname);
- (undef,$udom,$uname)=split(/\//,$uri);
- if(defined($userdomain)) {
+ if ($getuserdir) {
$udom = $userdomain;
- }
- if(defined($username)) {
$uname = $username;
+ } else {
+ (undef,$udom,$uname)=split(/\//,$uri);
+ if(defined($userdomain)) {
+ $udom = $userdomain;
+ }
+ if(defined($username)) {
+ $uname = $username;
+ }
}
+ my ($dirRoot,$listing,@listing_results);
- my $dirRoot = $perlvar{'lonDocRoot'};
- if(defined($alternateDirectoryRoot)) {
- $dirRoot = $alternateDirectoryRoot;
+ $dirRoot = $perlvar{'lonDocRoot'};
+ if (defined($getpropath)) {
+ $dirRoot = &propath($udom,$uname);
$dirRoot =~ s/\/$//;
+ } elsif (defined($getuserdir)) {
+ my $subdir=$uname.'__';
+ $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
+ $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
+ ."/$udom/$subdir/$uname";
+ } elsif (defined($alternateRoot)) {
+ $dirRoot = $alternateRoot;
}
if($udom) {
if($uname) {
- my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
- &homeserver($uname,$udom));
- my @listing_results;
+ $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
+ .$getuserdir.':'.&escape($dirRoot)
+ .':'.&escape($uname).':'.&escape($udom),
+ &homeserver($uname,$udom));
+ if ($listing eq 'unknown_cmd') {
+ $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
+ &homeserver($uname,$udom));
+ } else {
+ @listing_results = map { &unescape($_); } split(/:/,$listing);
+ }
if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$dirRoot.'/'.$uri,
&homeserver($uname,$udom));
@@ -5871,13 +6371,18 @@ sub dirlist {
@listing_results = map { &unescape($_); } split(/:/,$listing);
}
return @listing_results;
- } elsif(!defined($alternateDirectoryRoot)) {
+ } elsif(!$alternateRoot) {
my %allusers;
my %servers = &get_servers($udom,'library');
- foreach my $tryserver (keys(%servers)) {
- my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
- $udom, $tryserver);
- my @listing_results;
+ foreach my $tryserver (keys(%servers)) {
+ $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
+ &escape($udom),$tryserver);
+ if ($listing eq 'unknown_cmd') {
+ $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
+ } else {
+ @listing_results = map { &unescape($_); } split(/:/,$listing);
+ }
if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);
@@ -5904,13 +6409,13 @@ sub dirlist {
} else {
return ('missing user name');
}
- } elsif(!defined($alternateDirectoryRoot)) {
+ } elsif(!defined($getpropath)) {
my @all_domains = sort(&all_domains());
- foreach my $domain (@all_domains) {
- $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
- }
- return @all_domains;
- } else {
+ foreach my $domain (@all_domains) {
+ $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
+ }
+ return @all_domains;
+ } else {
return ('missing domain');
}
}
@@ -5920,23 +6425,13 @@ sub dirlist {
# when it was last modified. It will also return an error of -1
# if an error occurs
-##
-## FIXME: This subroutine assumes its caller knows something about the
-## directory structure of the home server for the student ($root).
-## Not a good assumption to make. Since this is for looking up files
-## in user directories, the full path should be constructed by lond, not
-## whatever machine we request data from.
-##
sub GetFileTimestamp {
- my ($studentDomain,$studentName,$filename,$root)=@_;
+ my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
$studentDomain = &LONCAPA::clean_domain($studentDomain);
$studentName = &LONCAPA::clean_username($studentName);
- my $subdir=$studentName.'__';
- $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
- my $proname="$studentDomain/$subdir/$studentName";
- $proname .= '/'.$filename;
- my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
- $studentName, $root);
+ my ($fileStat) =
+ &Apache::lonnet::dirlist($filename,$studentDomain,$studentName,
+ undef,$getuserdir);
my @stats = split('&', $fileStat);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
# @stats contains first the filename, then the stat output
@@ -5950,12 +6445,11 @@ sub stat_file {
my ($uri) = @_;
$uri = &clutter_with_no_wrapper($uri);
- my ($udom,$uname,$file,$dir);
+ my ($udom,$uname,$file);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
$file = 'userfiles/'.$file;
- $dir = &propath($udom,$uname);
}
if ($uri =~ m-^/res/-) {
($udom,$uname) =
@@ -5967,8 +6461,11 @@ sub stat_file {
# unable to handle the uri
return ();
}
-
- my ($result) = &dirlist($file,$udom,$uname,$dir);
+ my $getpropath;
+ if ($file =~ /^userfiles\//) {
+ $getpropath = 1;
+ }
+ my ($result) = &dirlist($file,$udom,$uname,$getpropath);
my @stats = split('&', $result);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
@@ -6001,7 +6498,7 @@ sub directcondval {
untie(%bighash);
}
my $value = &docondval($sub_condition);
- &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
+ &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
return $value;
}
if ($env{'user.state.'.$env{'request.course.id'}}) {
@@ -6158,8 +6655,8 @@ sub resdata {
}
if (!ref($result)) { return $result; }
foreach my $item (@which) {
- if (defined($result->{$item})) {
- return $result->{$item};
+ if (defined($result->{$item->[0]})) {
+ return [$result->{$item->[0]},$item->[1]];
}
}
return undef;
@@ -6187,7 +6684,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
@@ -6371,24 +6868,27 @@ sub EXT {
# ----------------------------------------------------------- first, check user
my $userreply=&resdata($uname,$udom,'user',
- ($courselevelr,$courselevelm,
- $courselevel));
- if (defined($userreply)) { return $userreply; }
+ ([$courselevelr,'resource'],
+ [$courselevelm,'map' ],
+ [$courselevel, 'course' ]));
+ if (defined($userreply)) { return &get_reply($userreply); }
# ------------------------------------------------ second, check some of course
my $coursereply;
if (@groups > 0) {
$coursereply = &check_group_parms($courseid,\@groups,$symbparm,
$mapparm,$spacequalifierrest);
- if (defined($coursereply)) { return $coursereply; }
+ if (defined($coursereply)) { return &get_reply($coursereply); }
}
$coursereply=&resdata($env{'course.'.$courseid.'.num'},
- $env{'course.'.$courseid.'.domain'},
- 'course',
- ($seclevelr,$seclevelm,$seclevel,
- $courselevelr));
- if (defined($coursereply)) { return $coursereply; }
+ $env{'course.'.$courseid.'.domain'},
+ 'course',
+ ([$seclevelr, 'resource'],
+ [$seclevelm, 'map' ],
+ [$seclevel, 'course' ],
+ [$courselevelr,'resource']));
+ if (defined($coursereply)) { return &get_reply($coursereply); }
# ------------------------------------------------------ third, check map parms
my %parmhash=();
@@ -6399,7 +6899,7 @@ sub EXT {
$thisparm=$parmhash{$symbparm};
untie(%parmhash);
}
- if ($thisparm) { return $thisparm; }
+ if ($thisparm) { return &get_reply([$thisparm,'resource']); }
}
# ------------------------------------------ fourth, look in resource metadata
@@ -6412,18 +6912,19 @@ sub EXT {
$filename=$env{'request.filename'};
}
my $metadata=&metadata($filename,$spacequalifierrest);
- if (defined($metadata)) { return $metadata; }
+ if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
- if (defined($metadata)) { return $metadata; }
+ if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
-# ---------------------------------------------- fourth, look in rest pf course
+# ---------------------------------------------- fourth, look in rest of course
if ($symbparm && defined($courseid) &&
$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; }
+ ([$courselevelm,'map' ],
+ [$courselevel, 'course']));
+ if (defined($coursereply)) { return &get_reply($coursereply); }
}
# ------------------------------------------------------------------ Cascade up
unless ($space eq '0') {
@@ -6431,14 +6932,13 @@ sub EXT {
my $id=pop(@parts);
my $part=join('_',@parts);
if ($part eq '') { $part='0'; }
- my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+ my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
$symbparm,$udom,$uname,$section,1);
- if (defined($partgeneral)) { return $partgeneral; }
+ if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
}
if ($recurse) { return undef; }
my $pack_def=&packages_tab_default($filename,$varname);
- if (defined($pack_def)) { return $pack_def; }
-
+ if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
@@ -6466,15 +6966,27 @@ sub EXT {
return '';
}
+sub get_reply {
+ my ($reply_value) = @_;
+ if (ref($reply_value) eq 'ARRAY') {
+ if (wantarray) {
+ return @$reply_value;
+ }
+ return $reply_value->[0];
+ } else {
+ return $reply_value;
+ }
+}
+
sub check_group_parms {
my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
my @groupitems = ();
my $resultitem;
- my @levels = ($symbparm,$mapparm,$what);
+ my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
foreach my $group (@{$groups}) {
foreach my $level (@levels) {
- my $item = $courseid.'.['.$group.'].'.$level;
- push(@groupitems,$item);
+ my $item = $courseid.'.['.$group.'].'.$level->[0];
+ push(@groupitems,[$item,$level->[1]]);
}
}
my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
@@ -6567,8 +7079,11 @@ sub metadata {
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
- ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
- ($uri =~ m|home/$match_username/public_html/|)) {
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {
+ return undef;
+ }
+ if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})
+ && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
return undef;
}
my $filename=$uri;
@@ -6589,6 +7104,7 @@ sub metadata {
# if (! exists($metacache{$uri})) {
# $metacache{$uri}={};
# }
+ my $cachetime = 60*60;
if ($liburi) {
$liburi=&declutter($liburi);
$filename=$liburi;
@@ -6599,7 +7115,13 @@ sub metadata {
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;
- if ($uri !~ m -^(editupload)/-) {
+ if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {
+ my $which = &hreflocation('','/'.($liburi || $uri));
+ $metastring =
+ &Apache::lonnet::ssi_body($which,
+ ('grade_target' => 'meta'));
+ $cachetime = 1; # only want this cached in the child not long term
+ } elsif ($uri !~ m -^(editupload)/-) {
my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);
@@ -6766,7 +7288,7 @@ sub metadata {
$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
- &do_cache_new('meta',$uri,\%metaentry,60*60);
+ &do_cache_new('meta',$uri,\%metaentry,$cachetime);
# this is the end of "was not already recently cached
}
return $metaentry{':'.$what};
@@ -7064,7 +7586,7 @@ sub symbread {
if ($syval) {
#unless ($syval=~/\_\d+$/) {
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
- #&appenv('request.ambiguous' => $thisfn);
+ #&appenv({'request.ambiguous' => $thisfn});
#return $env{$cache_str}='';
#}
#$syval.=$1;
@@ -7116,7 +7638,7 @@ sub symbread {
return $env{$cache_str}=$syval;
}
}
- &appenv('request.ambiguous' => $thisfn);
+ &appenv({'request.ambiguous' => $thisfn});
return $env{$cache_str}='';
}
@@ -7630,7 +8152,7 @@ sub tokenwrapper {
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'};
@@ -7688,6 +8210,8 @@ sub filelocation {
} elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference
$location = $file;
+ } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
+ $location = $file;
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
@@ -7696,8 +8220,7 @@ sub filelocation {
my @ids=¤t_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {
- $location=&propath($udom,$uname).
- '/userfiles/'.$filename;
+ $location=&propath($udom,$uname).'/userfiles/'.$filename;
} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;
@@ -7714,7 +8237,13 @@ sub filelocation {
}
}
$location=~s://+:/:g; # remove duplicate /
- while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
+ while ($location=~m{/\.\./}) {
+ if ($location =~ m{/[^/]+/\.\./}) {
+ $location=~ s{/[^/]+/\.\./}{/}g;
+ } else {
+ $location=~ s{/\.\./}{/}g;
+ }
+ } #remove dir/..
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;
}
@@ -7735,6 +8264,9 @@ sub hreflocation {
$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;
}
+ if ($file=~ m{^/userfiles/}) {
+ $file =~ s{^/userfiles/}{/uploaded/};
+ }
return $file;
}
@@ -8284,6 +8816,7 @@ $memcache=new Cache::Memcached({'servers
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
+$locknum=0;
&logtouch();
&logthis('INFO: Read configuration');
@@ -8466,10 +8999,12 @@ that was requested
=item *
X
-B: the value of %hash is written to
+B: the value of %{$hashref} 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
-process
+process. Optional rolesarrayref - if defined contains a reference to an array
+of roles which are exempt from the restriction on modifying user.role entries
+in the user's environment.db and in %env.
=item *
X
@@ -8577,14 +9112,15 @@ explanation of a user role term
=item *
-get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
+get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
All arguments are optional. Returns a hash of a roles, either for
co-author/assistant author roles for a user's Construction Space
(default), or if $context is 'userroles', roles for the user himself,
-In the hash, keys are set to colon-sparated $uname,$udom,and $role,
-and value is set to colon-separated start and end times for the role.
-If no username and domain are specified, will default to current
-user/domain. Types, roles, and roledoms are references to arrays,
+In the hash, keys are set to colon-separated $uname,$udom,$role, and
+(optionally) if $withsec is true, a fourth colon-separated item - $section.
+For each key, value is set to colon-separated start and end times for
+the role. If no username and domain are specified, will default to
+current user/domain. Types, roles, and roledoms are references to arrays
of role statuses (active, future or previous), roles
(e.g., cc,in, st etc.) and domains of the roles which can be used
to restrict the list of roles reported. If no array ref is
@@ -8598,7 +9134,7 @@ provided for types, will default to retu
=item *
-assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
+assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
user for the level given by URL. Optional start and end dates (leave empty
string or zero for "no date")
@@ -8615,14 +9151,15 @@ modifyuserauth($udom,$uname,$umode,$upas
=item *
-modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :
+modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
+ $forceid,$desiredhome,$email,$inststatus) :
modify user
=item *
modifystudent
-modify a students enrollment and identification information.
+modify a student's enrollment and identification information.
The course id is resolved based on the current users environment.
This means the envoking user must be a course coordinator or otherwise
associated with a course.
@@ -8634,25 +9171,25 @@ Inputs:
=over 4
-=item B<$udom> Students loncapa domain
+=item B<$udom> Student's loncapa domain
-=item B<$uname> Students loncapa login name
+=item B<$uname> Student's loncapa login name
-=item B<$uid> Students id/student number
+=item B<$uid> Student's id/student number
-=item B<$umode> Students authentication mode
+=item B<$umode> Student's authentication mode
-=item B<$upass> Students password
+=item B<$upass> Student's password
-=item B<$first> Students first name
+=item B<$first> Student's first name
-=item B<$middle> Students middle name
+=item B<$middle> Student's middle name
-=item B<$last> Students last name
+=item B<$last> Student's last name
-=item B<$gene> Students generation
+=item B<$gene> Student's generation
-=item B<$usec> Students section in course
+=item B<$usec> Student's section in course
=item B<$end> Unix time of the roles expiration
@@ -8662,6 +9199,20 @@ Inputs:
=item B<$desiredhome> server to use as home server for student
+=item B<$email> Student's permanent e-mail address
+
+=item B<$type> Type of enrollment (auto or manual)
+
+=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto
+
+=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
+
+=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
+
+=item B<$context> role change context (shown in User Management Logs display in a course)
+
+=item B<$inststatus> institutional status of user - : separated string of escaped status types
+
=back
=item *
@@ -8695,6 +9246,16 @@ Inputs:
=item $start
+=item $type
+
+=item $locktype
+
+=item $cid
+
+=item $selfenroll
+
+=item $context
+
=back
@@ -9031,6 +9592,18 @@ put_dom($namespace,$storehash,$udom,$uho
domain level either on specified domain server ($uhome) or primary domain
server ($udom and $uhome are optional)
+=item *
+
+get_domain_defaults($target_domain) : returns hash with defaults for
+authentication and language in the domain. Keys are: auth_def, auth_arg_def,
+lang_def; corresponsing values are authentication type (internal, krb4, krb5,
+or localauth), initial password or a kerberos realm, language (e.g., en-us).
+Values are retrieved from cache (if current), or from domain's configuration.db
+(if available), or lastly from values in lonTabs/dns_domain,tab,
+or lonTabs/domain.tab.
+
+%domdefaults = &get_auth_defaults($target_domain);
+
=back
=head2 Network Status Functions