version 1.947, 2008/03/09 17:22:21
|
version 1.953, 2008/03/28 14:52:57
|
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 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=&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 1746 sub allowuploaded {
|
Line 1774 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 2477 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 2502 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 3399 sub coursedescription {
|
Line 3436 sub coursedescription {
|
} |
} |
} |
} |
if (!$args->{'one_time'}) { |
if (!$args->{'one_time'}) { |
&appenv(%envhash); |
&appenv(\%envhash); |
} |
} |
return %returnhash; |
return %returnhash; |
} |
} |
Line 3948 sub tmpget {
|
Line 3985 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 6342 sub directcondval {
|
Line 6380 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 6528 sub EXT_cache_status {
|
Line 6566 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 7430 sub symbread {
|
Line 7468 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 7482 sub symbread {
|
Line 7520 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 7996 sub tokenwrapper {
|
Line 8034 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 8841 that was requested
|
Line 8879 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()> |