--- loncom/lonnet/perl/lonnet.pm 2008/03/22 15:47:41 1.950
+++ loncom/lonnet/perl/lonnet.pm 2008/09/01 17:58:30 1.966
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.950 2008/03/22 15:47:41 raeburn Exp $
+# $Id: lonnet.pm,v 1.966 2008/09/01 17:58:30 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);
}
}
@@ -524,6 +526,51 @@ 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
sub userload {
my $numusers=0;
@@ -705,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");
@@ -897,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) {
@@ -1679,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*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
$output=~s/^.*?\<body[^\>]*\>//si;
$output=~s/\<\/body\s*\>.*?$//si;
- return $output;
+ if (wantarray) {
+ return ($output, $response);
+ } else {
+ return $output;
+ }
}
# --------------------------------------------------------- Server Side Include
@@ -1738,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
@@ -1812,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);
}
@@ -2020,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.
@@ -2060,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 => '',
@@ -2075,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') {
@@ -2453,6 +2531,36 @@ 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,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
@@ -2658,7 +2766,7 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
- $selfenrollonly)=@_;
+ $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -2676,7 +2784,8 @@ sub courseiddump {
&escape($instcodefilter).':'.&escape($ownerfilter).
':'.&escape($coursefilter).':'.&escape($typefilter).
':'.&escape($regexp_ok).':'.$as_hash.':'.
- &escape($selfenrollonly),$tryserver);
+ &escape($selfenrollonly).':'.&escape($catfilter).':'.
+ $showhidden.':'.$caller,$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3452,12 +3561,13 @@ sub privileged {
sub rolesinit {
my ($domain,$username,$authhost)=@_;
+ my %userroles;
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
+ if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; }
my %allroles=();
my %allgroups=();
my $now=time;
- my %userroles = ('user.login.time' => $now);
+ %userroles = ('user.login.time' => $now);
my $group_privs;
if ($rolesdump ne '') {
@@ -3962,6 +4072,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;
@@ -4429,7 +4540,6 @@ sub allowed {
}
# Full access at system, domain or course-wide level? Exit.
-
if ($thisallowed=~/F/) {
return 'F';
}
@@ -5208,11 +5318,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);
}
@@ -5328,7 +5438,8 @@ sub plaintext {
# ----------------------------------------------------------------- Assign Role
sub assignrole {
- my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_;
+ my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
+ $context)=@_;
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
@@ -5387,6 +5498,7 @@ sub assignrole {
}
my $origstart = $start;
my $origend = $end;
+ my $delflag;
# actually delete
if ($deleteflag) {
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
@@ -5397,6 +5509,7 @@ sub assignrole {
# set start and finish to negative values for userrolelog
$start=-1;
$end=-1;
+ $delflag = 1;
}
}
# send command
@@ -5405,9 +5518,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;
@@ -5445,7 +5559,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.', '.
@@ -5506,7 +5620,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:.*/) {
@@ -5524,19 +5638,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';
}
@@ -5544,7 +5662,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';
@@ -5559,12 +5678,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,$selfenroll) = @_;
+ 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'}) {
@@ -5622,7 +5741,7 @@ sub modify_student_enrollment {
if ($usec) {
$uurl.='/'.$usec;
}
- return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll);
+ return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
}
sub format_name {
@@ -5751,33 +5870,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,undef,$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;
}
@@ -6194,30 +6321,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));
@@ -6226,13 +6372,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);
@@ -6259,13 +6410,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');
}
}
@@ -6275,23 +6426,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
@@ -6305,12 +6446,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) =
@@ -6322,8 +6462,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') {
@@ -8068,6 +8211,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)/+(.*)$-);
@@ -8076,8 +8221,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;
@@ -8673,6 +8817,7 @@ $memcache=new Cache::Memcached({'servers
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
+$locknum=0;
&logtouch();
&logthis('<font color="yellow">INFO: Read configuration</font>');
@@ -8990,7 +9135,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")
@@ -9007,14 +9152,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.
@@ -9026,25 +9172,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/Employee ID
-=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
@@ -9054,6 +9200,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 *
@@ -9087,6 +9247,16 @@ Inputs:
=item $start
+=item $type
+
+=item $locktype
+
+=item $cid
+
+=item $selfenroll
+
+=item $context
+
=back