|
version 1.950, 2008/03/22 15:47:41
|
version 1.959, 2008/05/29 05:44:53
|
|
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 705 sub queryauthenticate {
|
Line 752 sub queryauthenticate {
|
| # --------- Try to authenticate user from domain's lib servers (first this one) |
# --------- Try to authenticate user from domain's lib servers (first this one) |
| |
|
| sub authenticate { |
sub authenticate { |
| my ($uname,$upass,$udom)=@_; |
my ($uname,$upass,$udom,$checkdefauth)=@_; |
| $upass=&escape($upass); |
$upass=&escape($upass); |
| $uname= &LONCAPA::clean_username($uname); |
$uname= &LONCAPA::clean_username($uname); |
| my $uhome=&homeserver($uname,$udom,1); |
my $uhome=&homeserver($uname,$udom,1); |
| |
my $newhome; |
| if ((!$uhome) || ($uhome eq 'no_host')) { |
if ((!$uhome) || ($uhome eq 'no_host')) { |
| # Maybe the machine was offline and only re-appeared again recently? |
# Maybe the machine was offline and only re-appeared again recently? |
| &reconlonc(); |
&reconlonc(); |
| # One more |
# 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')) { |
if ((!$uhome) || ($uhome eq 'no_host')) { |
| &logthis("User $uname at $udom is unknown in authenticate"); |
&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') { |
if ($answer eq 'authorized') { |
| &logthis("User $uname at $udom authorized by $uhome"); |
if ($newhome) { |
| return $uhome; |
&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') { |
if ($answer eq 'non_authorized') { |
| &logthis("User $uname at $udom rejected by $uhome"); |
&logthis("User $uname at $udom rejected by $uhome"); |
|
Line 1679 sub ssi_body {
|
Line 1740 sub ssi_body {
|
| if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { |
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { |
| $form{'LONCAPA_INTERNAL_no_discussion'}='true'; |
$form{'LONCAPA_INTERNAL_no_discussion'}='true'; |
| } |
} |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=''; |
| &ssi($filelink,%form)); |
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|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs; |
| $output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/^.*?\<body[^\>]*\>//si; |
| $output=~s/\<\/body\s*\>.*?$//si; |
$output=~s/\<\/body\s*\>.*?$//si; |
| return $output; |
if (wantarray) { |
| |
return ($output, $response); |
| |
} else { |
| |
return $output; |
| |
} |
| } |
} |
| |
|
| # --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
|
Line 1738 sub externalssi {
|
Line 1808 sub externalssi {
|
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request('GET',$url); |
my $request=new HTTP::Request('GET',$url); |
| my $response=$ua->request($request); |
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 |
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
|
Line 2453 sub userrolelog {
|
Line 2527 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 2658 sub courseidput {
|
Line 2762 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 2676 sub courseiddump {
|
Line 2780 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 3962 sub tmpget {
|
Line 4066 sub tmpget {
|
| my %returnhash; |
my %returnhash; |
| foreach my $item (split(/\&/,$rep)) { |
foreach my $item (split(/\&/,$rep)) { |
| my ($key,$value)=split(/=/,$item); |
my ($key,$value)=split(/=/,$item); |
| |
next if ($key =~ /^error: 2 /); |
| $returnhash{&unescape($key)}=&thaw_unescape($value); |
$returnhash{&unescape($key)}=&thaw_unescape($value); |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 5208 sub toggle_coursegroup_status {
|
Line 5313 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 5328 sub plaintext {
|
Line 5433 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 5387 sub assignrole {
|
Line 5493 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 5397 sub assignrole {
|
Line 5504 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 5405 sub assignrole {
|
Line 5513 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 5544 sub modifyuser {
|
Line 5653 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 5559 sub modifystudent {
|
Line 5669 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 5622 sub modify_student_enrollment {
|
Line 5732 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 5751 sub is_course {
|
Line 5861 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 |
| sub diskusage { |
sub diskusage { |
| my ($udom,$uname,$directoryRoot)=@_; |
my ($udom,$uname,$directorypath,$getpropath)=@_; |
| $directoryRoot =~ s/\/$//; |
$directorypath =~ s/\/$//; |
| my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); |
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; |
return $listing; |
| } |
} |
| |
|
|
Line 6194 sub unmark_as_readonly {
|
Line 6312 sub unmark_as_readonly {
|
| # ------------------------------------------------------------ Directory lister |
# ------------------------------------------------------------ Directory lister |
| |
|
| sub dirlist { |
sub dirlist { |
| my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; |
my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_; |
| |
|
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $uri=~s/\/$//; |
$uri=~s/\/$//; |
| my ($udom, $uname); |
my ($udom, $uname); |
| (undef,$udom,$uname)=split(/\//,$uri); |
if ($getuserdir) { |
| if(defined($userdomain)) { |
|
| $udom = $userdomain; |
$udom = $userdomain; |
| } |
|
| if(defined($username)) { |
|
| $uname = $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'}; |
$dirRoot = $perlvar{'lonDocRoot'}; |
| if(defined($alternateDirectoryRoot)) { |
if (defined($getpropath)) { |
| $dirRoot = $alternateDirectoryRoot; |
$dirRoot = &propath($udom,$uname); |
| $dirRoot =~ s/\/$//; |
$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($udom) { |
| if($uname) { |
if($uname) { |
| my $listing = &reply('ls2:'.$dirRoot.'/'.$uri, |
$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' |
| &homeserver($uname,$udom)); |
.$getuserdir.':'.&escape($dirRoot) |
| my @listing_results; |
.':'.&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') { |
if ($listing eq 'unknown_cmd') { |
| $listing = &reply('ls:'.$dirRoot.'/'.$uri, |
$listing = &reply('ls:'.$dirRoot.'/'.$uri, |
| &homeserver($uname,$udom)); |
&homeserver($uname,$udom)); |
|
Line 6226 sub dirlist {
|
Line 6363 sub dirlist {
|
| @listing_results = map { &unescape($_); } split(/:/,$listing); |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| } |
} |
| return @listing_results; |
return @listing_results; |
| } elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!$alternateRoot) { |
| my %allusers; |
my %allusers; |
| my %servers = &get_servers($udom,'library'); |
my %servers = &get_servers($udom,'library'); |
| foreach my $tryserver (keys(%servers)) { |
foreach my $tryserver (keys(%servers)) { |
| my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
$listing = &reply('ls3:'.&escape("/res/$udom").':::::'. |
| $udom, $tryserver); |
&escape($udom),$tryserver); |
| my @listing_results; |
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') { |
if ($listing eq 'unknown_cmd') { |
| $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
| $udom, $tryserver); |
$udom, $tryserver); |
|
Line 6259 sub dirlist {
|
Line 6401 sub dirlist {
|
| } else { |
} else { |
| return ('missing user name'); |
return ('missing user name'); |
| } |
} |
| } elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!defined($getpropath)) { |
| my @all_domains = sort(&all_domains()); |
my @all_domains = sort(&all_domains()); |
| foreach my $domain (@all_domains) { |
foreach my $domain (@all_domains) { |
| $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; |
$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; |
| } |
} |
| return @all_domains; |
return @all_domains; |
| } else { |
} else { |
| return ('missing domain'); |
return ('missing domain'); |
| } |
} |
| } |
} |
|
Line 6275 sub dirlist {
|
Line 6417 sub dirlist {
|
| # when it was last modified. It will also return an error of -1 |
# when it was last modified. It will also return an error of -1 |
| # if an error occurs |
# 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 { |
sub GetFileTimestamp { |
| my ($studentDomain,$studentName,$filename,$root)=@_; |
my ($studentDomain,$studentName,$filename,$getuserdir)=@_; |
| $studentDomain = &LONCAPA::clean_domain($studentDomain); |
$studentDomain = &LONCAPA::clean_domain($studentDomain); |
| $studentName = &LONCAPA::clean_username($studentName); |
$studentName = &LONCAPA::clean_username($studentName); |
| my $subdir=$studentName.'__'; |
my ($fileStat) = |
| $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
&Apache::lonnet::dirlist($filename,$studentDomain,$studentName, |
| my $proname="$studentDomain/$subdir/$studentName"; |
undef,$getuserdir); |
| $proname .= '/'.$filename; |
|
| my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, |
|
| $studentName, $root); |
|
| my @stats = split('&', $fileStat); |
my @stats = split('&', $fileStat); |
| if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
| # @stats contains first the filename, then the stat output |
# @stats contains first the filename, then the stat output |
|
Line 6305 sub stat_file {
|
Line 6437 sub stat_file {
|
| my ($uri) = @_; |
my ($uri) = @_; |
| $uri = &clutter_with_no_wrapper($uri); |
$uri = &clutter_with_no_wrapper($uri); |
| |
|
| my ($udom,$uname,$file,$dir); |
my ($udom,$uname,$file); |
| if ($uri =~ m-^/(uploaded|editupload)/-) { |
if ($uri =~ m-^/(uploaded|editupload)/-) { |
| ($udom,$uname,$file) = |
($udom,$uname,$file) = |
| ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); |
($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); |
| $file = 'userfiles/'.$file; |
$file = 'userfiles/'.$file; |
| $dir = &propath($udom,$uname); |
|
| } |
} |
| if ($uri =~ m-^/res/-) { |
if ($uri =~ m-^/res/-) { |
| ($udom,$uname) = |
($udom,$uname) = |
|
Line 6322 sub stat_file {
|
Line 6453 sub stat_file {
|
| # unable to handle the uri |
# unable to handle the uri |
| return (); |
return (); |
| } |
} |
| |
my $getpropath; |
| my ($result) = &dirlist($file,$udom,$uname,$dir); |
if ($file =~ /^userfiles\//) { |
| |
$getpropath = 1; |
| |
} |
| |
my ($result) = &dirlist($file,$udom,$uname,$getpropath); |
| my @stats = split('&', $result); |
my @stats = split('&', $result); |
| |
|
| if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
|
Line 8068 sub filelocation {
|
Line 8202 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 8076 sub filelocation {
|
Line 8212 sub filelocation {
|
| my @ids=¤t_machine_ids(); |
my @ids=¤t_machine_ids(); |
| foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
| if ($is_me) { |
if ($is_me) { |
| $location=&propath($udom,$uname). |
$location=&propath($udom,$uname).'/userfiles/'.$filename; |
| '/userfiles/'.$filename; |
|
| } else { |
} else { |
| $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
| $udom.'/'.$uname.'/'.$filename; |
$udom.'/'.$uname.'/'.$filename; |
|
Line 8673 $memcache=new Cache::Memcached({'servers
|
Line 8808 $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 8990 provided for types, will default to retu
|
Line 9126 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 9014 modify user
|
Line 9150 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 9026 Inputs:
|
Line 9162 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 9054 Inputs:
|
Line 9190 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 9087 Inputs:
|
Line 9235 Inputs:
|
| |
|
| =item $start |
=item $start |
| |
|
| |
=item $type |
| |
|
| |
=item $locktype |
| |
|
| |
=item $cid |
| |
|
| |
=item $selfenroll |
| |
|
| |
=item $context |
| |
|
| =back |
=back |
| |
|
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl