version 1.955, 2008/04/16 22:59:36
|
version 1.960, 2008/06/06 04:53:51
|
Line 39 use vars qw(%perlvar %spareid %pr %prp $
|
Line 39 use vars qw(%perlvar %spareid %pr %prp $
|
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, |
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, |
%courseownerbuf, %coursetypebuf); |
%courseownerbuf, %coursetypebuf,$locknum); |
|
|
use IO::Socket; |
use IO::Socket; |
use GDBM_File; |
use GDBM_File; |
Line 88 delayed.
|
Line 88 delayed.
|
{ |
{ |
my $logid; |
my $logid; |
sub instructor_log { |
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++; |
$logid++; |
my $id=time().'00000'.$$.'00000'.$logid; |
my $now = time(); |
|
my $id=$now.'00000'.$$.'00000'.$logid; |
return &Apache::lonnet::put('nohist_'.$hash_name, |
return &Apache::lonnet::put('nohist_'.$hash_name, |
{ $id => { |
{ $id => { |
'exe_uname' => $env{'user.name'}, |
'exe_uname' => $env{'user.name'}, |
'exe_udom' => $env{'user.domain'}, |
'exe_udom' => $env{'user.domain'}, |
'exe_time' => time(), |
'exe_time' => $now, |
'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'delflag' => $delflag, |
'delflag' => $delflag, |
'logentry' => $storehash, |
'logentry' => $storehash, |
'uname' => $uname, |
'uname' => $uname, |
'udom' => $udom, |
'udom' => $udom, |
} |
} |
}, |
},$cdom,$cnum); |
$env{'course.'.$env{'request.course.id'}.'.domain'}, |
|
$env{'course.'.$env{'request.course.id'}.'.num'} |
|
); |
|
} |
} |
} |
} |
|
|
Line 524 sub get_env_multiple {
|
Line 526 sub get_env_multiple {
|
return(@values); |
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 |
# ------------------------------------------ Find out current server userload |
sub userload { |
sub userload { |
my $numusers=0; |
my $numusers=0; |
Line 911 sub retrieve_inst_usertypes {
|
Line 958 sub retrieve_inst_usertypes {
|
if (defined(&domain($udom,'primary'))) { |
if (defined(&domain($udom,'primary'))) { |
my $uhome=&domain($udom,'primary'); |
my $uhome=&domain($udom,'primary'); |
my $rep=&reply("inst_usertypes:$udom",$uhome); |
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 ($hashitems,$orderitems) = split(/:/,$rep); |
my @pairs=split(/\&/,$hashitems); |
my @pairs=split(/\&/,$hashitems); |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
Line 2480 sub userrolelog {
|
Line 2531 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 { |
sub get_course_adv_roles { |
my ($cid,$codes) = @_; |
my ($cid,$codes) = @_; |
$cid=$env{'request.course.id'} unless (defined($cid)); |
$cid=$env{'request.course.id'} unless (defined($cid)); |
Line 2685 sub courseidput {
|
Line 2766 sub courseidput {
|
sub courseiddump { |
sub courseiddump { |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$selfenrollonly)=@_; |
$selfenrollonly,$catfilter)=@_; |
my $as_hash = 1; |
my $as_hash = 1; |
my %returnhash; |
my %returnhash; |
if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
Line 2703 sub courseiddump {
|
Line 2784 sub courseiddump {
|
&escape($instcodefilter).':'.&escape($ownerfilter). |
&escape($instcodefilter).':'.&escape($ownerfilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
&escape($selfenrollonly),$tryserver); |
&escape($selfenrollonly).':'.&escape($catfilter),$tryserver); |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
my ($key,$value)=split(/\=/,$item,2); |
my ($key,$value)=split(/\=/,$item,2); |
Line 4457 sub allowed {
|
Line 4538 sub allowed {
|
} |
} |
|
|
# Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
|
|
if ($thisallowed=~/F/) { |
if ($thisallowed=~/F/) { |
return 'F'; |
return 'F'; |
} |
} |
Line 5236 sub toggle_coursegroup_status {
|
Line 5316 sub toggle_coursegroup_status {
|
} |
} |
|
|
sub modify_group_roles { |
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 $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; |
my $role = 'gr/'.&escape($userprivs); |
my $role = 'gr/'.&escape($userprivs); |
my ($uname,$udom) = split(/:/,$user); |
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') { |
if ($result eq 'ok') { |
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); |
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); |
} |
} |
Line 5356 sub plaintext {
|
Line 5436 sub plaintext {
|
# ----------------------------------------------------------------- Assign Role |
# ----------------------------------------------------------------- Assign Role |
|
|
sub assignrole { |
sub assignrole { |
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_; |
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll, |
|
$context)=@_; |
my $mrole; |
my $mrole; |
if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
my $cwosec=$url; |
my $cwosec=$url; |
Line 5415 sub assignrole {
|
Line 5496 sub assignrole {
|
} |
} |
my $origstart = $start; |
my $origstart = $start; |
my $origend = $end; |
my $origend = $end; |
|
my $delflag; |
# actually delete |
# actually delete |
if ($deleteflag) { |
if ($deleteflag) { |
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { |
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { |
Line 5425 sub assignrole {
|
Line 5507 sub assignrole {
|
# set start and finish to negative values for userrolelog |
# set start and finish to negative values for userrolelog |
$start=-1; |
$start=-1; |
$end=-1; |
$end=-1; |
|
$delflag = 1; |
} |
} |
} |
} |
# send command |
# send command |
Line 5433 sub assignrole {
|
Line 5516 sub assignrole {
|
if ($answer eq 'ok') { |
if ($answer eq 'ok') { |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
# for course roles, perform group memberships changes triggered by role change. |
# for course roles, perform group memberships changes triggered by role change. |
|
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context); |
unless ($role =~ /^gr/) { |
unless ($role =~ /^gr/) { |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
$origstart); |
$origstart,$selfenroll,$context); |
} |
} |
} |
} |
return $answer; |
return $answer; |
Line 5572 sub modifyuser {
|
Line 5656 sub modifyuser {
|
|
|
sub modifystudent { |
sub modifystudent { |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
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) { |
if (!$cid) { |
unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
return 'not_in_class'; |
return 'not_in_class'; |
Line 5587 sub modifystudent {
|
Line 5672 sub modifystudent {
|
# students environment |
# students environment |
$uid = undef if (!$forceid); |
$uid = undef if (!$forceid); |
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
$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; |
return $reply; |
} |
} |
|
|
sub modify_student_enrollment { |
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); |
my ($cdom,$cnum,$chome); |
if (!$cid) { |
if (!$cid) { |
unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
Line 5650 sub modify_student_enrollment {
|
Line 5735 sub modify_student_enrollment {
|
if ($usec) { |
if ($usec) { |
$uurl.='/'.$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 { |
sub format_name { |
Line 5779 sub is_course {
|
Line 5864 sub is_course {
|
# ---------------------------------------------------------- Assign Custom Role |
# ---------------------------------------------------------- Assign Custom Role |
|
|
sub assigncustomrole { |
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, |
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, |
$end,$start,$deleteflag); |
$end,$start,$deleteflag,$selfenroll,$context); |
} |
} |
|
|
# ----------------------------------------------------------------- Revoke Role |
# ----------------------------------------------------------------- Revoke Role |
|
|
sub revokerole { |
sub revokerole { |
my ($udom,$uname,$url,$role,$deleteflag)=@_; |
my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; |
my $now=time; |
my $now=time; |
return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); |
return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context); |
} |
} |
|
|
# ---------------------------------------------------------- Revoke Custom Role |
# ---------------------------------------------------------- Revoke Custom Role |
|
|
sub revokecustomrole { |
sub revokecustomrole { |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_; |
my $now=time; |
my $now=time; |
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, |
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, |
$deleteflag); |
$deleteflag,$selfenroll,$context); |
} |
} |
|
|
# ------------------------------------------------------------ Disk usage |
# ------------------------------------------------------------ Disk usage |
Line 6264 sub dirlist {
|
Line 6349 sub dirlist {
|
if($udom) { |
if($udom) { |
if($uname) { |
if($uname) { |
$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' |
$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' |
.$getuserdir.':'.&escape($alternateRoot) |
.$getuserdir.':'.&escape($dirRoot) |
.':'.&escape($uname).':'.&escape($udom), |
.':'.&escape($uname).':'.&escape($udom), |
&homeserver($uname,$udom)); |
&homeserver($uname,$udom)); |
if ($listing eq 'unknown_cmd') { |
if ($listing eq 'unknown_cmd') { |
Line 6371 sub stat_file {
|
Line 6456 sub stat_file {
|
# unable to handle the uri |
# unable to handle the uri |
return (); |
return (); |
} |
} |
|
my $getpropath; |
my $getpropath = 1; |
if ($file =~ /^userfiles\//) { |
|
$getpropath = 1; |
|
} |
my ($result) = &dirlist($file,$udom,$uname,$getpropath); |
my ($result) = &dirlist($file,$udom,$uname,$getpropath); |
my @stats = split('&', $result); |
my @stats = split('&', $result); |
|
|
Line 8118 sub filelocation {
|
Line 8205 sub filelocation {
|
} elsif ($file=~m{^/home/$match_username/public_html/}) { |
} elsif ($file=~m{^/home/$match_username/public_html/}) { |
# is a correct contruction space reference |
# is a correct contruction space reference |
$location = $file; |
$location = $file; |
|
} elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { |
|
$location = $file; |
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
my ($udom,$uname,$filename)= |
my ($udom,$uname,$filename)= |
($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); |
($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); |
Line 8722 $memcache=new Cache::Memcached({'servers
|
Line 8811 $memcache=new Cache::Memcached({'servers
|
|
|
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$dumpcount=0; |
$dumpcount=0; |
|
$locknum=0; |
|
|
&logtouch(); |
&logtouch(); |
&logthis('<font color="yellow">INFO: Read configuration</font>'); |
&logthis('<font color="yellow">INFO: Read configuration</font>'); |
Line 9039 provided for types, will default to retu
|
Line 9129 provided for types, will default to retu
|
|
|
=item * |
=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 |
user for the level given by URL. Optional start and end dates (leave empty |
string or zero for "no date") |
string or zero for "no date") |
|
|
Line 9063 modify user
|
Line 9153 modify user
|
|
|
modifystudent |
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. |
The course id is resolved based on the current users environment. |
This means the envoking user must be a course coordinator or otherwise |
This means the envoking user must be a course coordinator or otherwise |
associated with a course. |
associated with a course. |
Line 9075 Inputs:
|
Line 9165 Inputs:
|
|
|
=over 4 |
=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 |
=item B<$end> Unix time of the roles expiration |
|
|
Line 9103 Inputs:
|
Line 9193 Inputs:
|
|
|
=item B<$desiredhome> server to use as home server for student |
=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> |
|
|
|
=item B<$cid> |
|
|
|
=item B<$selfenroll> |
|
|
|
=item B<$context> |
|
|
=back |
=back |
|
|
=item * |
=item * |
Line 9136 Inputs:
|
Line 9238 Inputs:
|
|
|
=item $start |
=item $start |
|
|
|
=item $type |
|
|
|
=item $locktype |
|
|
|
=item $cid |
|
|
|
=item $selfenroll |
|
|
|
=item $context |
|
|
=back |
=back |
|
|
|
|