|
version 1.944, 2008/02/26 10:39:44
|
version 1.955, 2008/04/16 22:59:36
|
|
Line 448 sub timed_flock {
|
Line 448 sub timed_flock {
|
| # ---------------------------------------------------------- Append Environment |
# ---------------------------------------------------------- Append Environment |
| |
|
| sub appenv { |
sub appenv { |
| my %newenv=@_; |
my ($newenv,$roles) = @_; |
| foreach my $key (keys(%newenv)) { |
if (ref($newenv) eq 'HASH') { |
| if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { |
foreach my $key (keys(%{$newenv})) { |
| &logthis("<font color=\"blue\">WARNING: ". |
my $refused = 0; |
| "Attempt to modify environment ".$key." to ".$newenv{$key} |
if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { |
| .'</font>'); |
$refused = 1; |
| delete($newenv{$key}); |
if (ref($roles) eq 'ARRAY') { |
| } else { |
my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./); |
| $env{$key}=$newenv{$key}; |
if (grep(/^\Q$role\E$/,@{$roles})) { |
| |
$refused = 0; |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| |
&logthis("<font color=\"blue\">WARNING: ". |
| |
"Attempt to modify environment ".$key." to ".$newenv->{$key} |
| |
.'</font>'); |
| |
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); |
| } |
} |
| } |
|
| 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); |
|
| } |
} |
| return 'ok'; |
return 'ok'; |
| } |
} |
|
Line 693 sub queryauthenticate {
|
Line 705 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 1064 sub inst_rulecheck {
|
Line 1090 sub inst_rulecheck {
|
| $response=&unescape(&reply('instidrulecheck:'.&escape($udom). |
$response=&unescape(&reply('instidrulecheck:'.&escape($udom). |
| ':'.&escape($id).':'.$rulestr, |
':'.&escape($id).':'.$rulestr, |
| $homeserver)); |
$homeserver)); |
| } elsif ($item eq 'selfenroll') { |
} elsif ($item eq 'selfcreate') { |
| $response=&unescape(&reply('instselfenrollcheck:'. |
$response=&unescape(&reply('instselfcreatecheck:'. |
| &escape($udom).':'.&escape($uname). |
&escape($udom).':'.&escape($uname). |
| ':'.$rulestr,$homeserver)); |
':'.$rulestr,$homeserver)); |
| } |
} |
|
Line 1183 sub assign_access_key {
|
Line 1209 sub assign_access_key {
|
| # key now belongs to user |
# key now belongs to user |
| my $envkey='key.'.$cdom.'_'.$cnum; |
my $envkey='key.'.$cdom.'_'.$cnum; |
| if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
| &appenv('environment.'.$envkey => $ckey); |
&appenv({'environment.'.$envkey => $ckey}); |
| return 'ok'; |
return 'ok'; |
| } else { |
} else { |
| return |
return |
|
Line 1667 sub ssi_body {
|
Line 1693 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 1693 sub absolute_url {
|
Line 1728 sub absolute_url {
|
| # form Hash that describes how the rendering should be done |
# form Hash that describes how the rendering should be done |
| # and other things. |
# and other things. |
| # Returns: |
# Returns: |
| # Scalar context: The content of the reply. |
# Scalar context: The content of the response. |
| # Array context: 2 element list of the content and the full response variable. |
# Array context: 2 element list of the content and the full response object. |
| # |
# |
| # Returns: |
|
| # The content of the response. |
|
| sub ssi { |
sub ssi { |
| |
|
| my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
| my $count = scalar(@_); |
|
| |
|
| |
|
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| |
|
| my $request; |
my $request; |
| |
|
| $form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
|
Line 1719 sub ssi {
|
Line 1748 sub ssi {
|
| |
|
| $request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
| my $status = $response->code; |
|
| |
|
| if (wantarray) { |
if (wantarray) { |
| return ($response->content, $response); |
return ($response->content, $response); |
|
Line 1733 sub externalssi {
|
Line 1761 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 1746 sub allowuploaded {
|
Line 1778 sub allowuploaded {
|
| my %httpref=(); |
my %httpref=(); |
| my $httpurl=&hreflocation('',$url); |
my $httpurl=&hreflocation('',$url); |
| $httpref{'httpref.'.$httpurl}=$srcurl; |
$httpref{'httpref.'.$httpurl}=$srcurl; |
| &Apache::lonnet::appenv(%httpref); |
&Apache::lonnet::appenv(\%httpref); |
| } |
} |
| |
|
| # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
|
Line 2449 sub userrolelog {
|
Line 2481 sub userrolelog {
|
| } |
} |
| |
|
| sub get_course_adv_roles { |
sub get_course_adv_roles { |
| my $cid=shift; |
my ($cid,$codes) = @_; |
| $cid=$env{'request.course.id'} unless (defined($cid)); |
$cid=$env{'request.course.id'} unless (defined($cid)); |
| my %coursehash=&coursedescription($cid); |
my %coursehash=&coursedescription($cid); |
| my %nothide=(); |
my %nothide=(); |
|
Line 2474 sub get_course_adv_roles {
|
Line 2506 sub get_course_adv_roles {
|
| if ((&privileged($username,$domain)) && |
if ((&privileged($username,$domain)) && |
| (!$nothide{$username.':'.$domain})) { next; } |
(!$nothide{$username.':'.$domain})) { next; } |
| if ($role eq 'cr') { next; } |
if ($role eq 'cr') { next; } |
| my $key=&plaintext($role); |
if ($codes) { |
| if ($section) { $key.=' (Sec/Grp '.$section.')'; } |
if ($section) { $role .= ':'.$section; } |
| if ($returnhash{$key}) { |
if ($returnhash{$role}) { |
| $returnhash{$key}.=','.$username.':'.$domain; |
$returnhash{$role}.=','.$username.':'.$domain; |
| |
} else { |
| |
$returnhash{$role}=$username.':'.$domain; |
| |
} |
| } else { |
} 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; |
return %returnhash; |
| } |
} |
| |
|
|
Line 2643 sub courseidput {
|
Line 2684 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)=@_; |
| my $as_hash = 1; |
my $as_hash = 1; |
| my %returnhash; |
my %returnhash; |
| if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
|
Line 2660 sub courseiddump {
|
Line 2702 sub courseiddump {
|
| $sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
| &escape($instcodefilter).':'.&escape($ownerfilter). |
&escape($instcodefilter).':'.&escape($ownerfilter). |
| ':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
| ':'.&escape($regexp_ok).':'.$as_hash,$tryserver); |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
| |
&escape($selfenrollonly),$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 3397 sub coursedescription {
|
Line 3440 sub coursedescription {
|
| } |
} |
| } |
} |
| if (!$args->{'one_time'}) { |
if (!$args->{'one_time'}) { |
| &appenv(%envhash); |
&appenv(\%envhash); |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
|
Line 3946 sub tmpget {
|
Line 3989 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 5312 sub plaintext {
|
Line 5356 sub plaintext {
|
| # ----------------------------------------------------------------- Assign Role |
# ----------------------------------------------------------------- Assign Role |
| |
|
| sub assignrole { |
sub assignrole { |
| my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; |
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_; |
| my $mrole; |
my $mrole; |
| if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
| my $cwosec=$url; |
my $cwosec=$url; |
|
Line 5346 sub assignrole {
|
Line 5390 sub assignrole {
|
| } else { |
} else { |
| $refused = 1; |
$refused = 1; |
| } |
} |
| if ($refused) { |
if ($refused) { |
| &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| ' '.$role.' '.$end.' '.$start.' by '. |
$refused = ''; |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
} else { |
| return 'refused'; |
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
| |
' '.$role.' '.$end.' '.$start.' by '. |
| |
$env{'user.name'}.' at '.$env{'user.domain'}); |
| |
return 'refused'; |
| |
} |
| } |
} |
| } |
} |
| $mrole=$role; |
$mrole=$role; |
|
Line 5544 sub modifystudent {
|
Line 5592 sub modifystudent {
|
| } |
} |
| |
|
| sub modify_student_enrollment { |
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) = @_; |
| 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 5602 sub modify_student_enrollment {
|
Line 5650 sub modify_student_enrollment {
|
| if ($usec) { |
if ($usec) { |
| $uurl.='/'.$usec; |
$uurl.='/'.$usec; |
| } |
} |
| return &assignrole($udom,$uname,$uurl,'st',$end,$start); |
return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll); |
| } |
} |
| |
|
| sub format_name { |
sub format_name { |
|
Line 5721 ENDINITMAP
|
Line 5769 ENDINITMAP
|
| sub is_course { |
sub is_course { |
| my ($cdom,$cnum) = @_; |
my ($cdom,$cnum) = @_; |
| my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
| undef,'.',undef,1); |
undef,'.'); |
| if (exists($courses{$cdom.'_'.$cnum})) { |
if (exists($courses{$cdom.'_'.$cnum})) { |
| return 1; |
return 1; |
| } |
} |
|
Line 5755 sub revokecustomrole {
|
Line 5803 sub revokecustomrole {
|
| |
|
| # ------------------------------------------------------------ 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 6174 sub unmark_as_readonly {
|
Line 6230 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($alternateRoot) |
| 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 6206 sub dirlist {
|
Line 6281 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 6239 sub dirlist {
|
Line 6319 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 6255 sub dirlist {
|
Line 6335 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 6285 sub stat_file {
|
Line 6355 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 6303 sub stat_file {
|
Line 6372 sub stat_file {
|
| return (); |
return (); |
| } |
} |
| |
|
| my ($result) = &dirlist($file,$udom,$uname,$dir); |
my $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 6336 sub directcondval {
|
Line 6406 sub directcondval {
|
| untie(%bighash); |
untie(%bighash); |
| } |
} |
| my $value = &docondval($sub_condition); |
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; |
return $value; |
| } |
} |
| if ($env{'user.state.'.$env{'request.course.id'}}) { |
if ($env{'user.state.'.$env{'request.course.id'}}) { |
|
Line 6522 sub EXT_cache_status {
|
Line 6592 sub EXT_cache_status {
|
| sub EXT_cache_set { |
sub EXT_cache_set { |
| my ($target_domain,$target_user) = @_; |
my ($target_domain,$target_user) = @_; |
| my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
| #&appenv($cachename => time); |
#&appenv({$cachename => time}); |
| } |
} |
| |
|
| # --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
|
Line 7424 sub symbread {
|
Line 7494 sub symbread {
|
| if ($syval) { |
if ($syval) { |
| #unless ($syval=~/\_\d+$/) { |
#unless ($syval=~/\_\d+$/) { |
| #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { |
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { |
| #&appenv('request.ambiguous' => $thisfn); |
#&appenv({'request.ambiguous' => $thisfn}); |
| #return $env{$cache_str}=''; |
#return $env{$cache_str}=''; |
| #} |
#} |
| #$syval.=$1; |
#$syval.=$1; |
|
Line 7476 sub symbread {
|
Line 7546 sub symbread {
|
| return $env{$cache_str}=$syval; |
return $env{$cache_str}=$syval; |
| } |
} |
| } |
} |
| &appenv('request.ambiguous' => $thisfn); |
&appenv({'request.ambiguous' => $thisfn}); |
| return $env{$cache_str}=''; |
return $env{$cache_str}=''; |
| } |
} |
| |
|
|
Line 7990 sub tokenwrapper {
|
Line 8060 sub tokenwrapper {
|
| my (undef,$udom,$uname,$file)=split('/',$uri,4); |
my (undef,$udom,$uname,$file)=split('/',$uri,4); |
| if ($udom && $uname && $file) { |
if ($udom && $uname && $file) { |
| $file=~s|(\?\.*)*$||; |
$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. |
return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. |
| (($uri=~/\?/)?'&':'?').'token='.$token. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| '&tokenissued='.$perlvar{'lonHostID'}; |
'&tokenissued='.$perlvar{'lonHostID'}; |
|
Line 8056 sub filelocation {
|
Line 8126 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 8835 that was requested
|
Line 8904 that was requested
|
| |
|
| =item * |
=item * |
| X<appenv()> |
X<appenv()> |
| B<appenv(%hash)>: the value of %hash is written to |
B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to |
| the user envirnoment file, and will be restored for each access this |
the user envirnoment file, and will be restored for each access this |
| user makes during this session, also modifies the %env for the current |
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 * |
=item * |
| X<delenv()> |
X<delenv()> |
![[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