--- loncom/lonnet/perl/lonnet.pm 2008/02/21 10:04:35 1.942
+++ loncom/lonnet/perl/lonnet.pm 2008/03/22 15:47:41 1.950
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.942 2008/02/21 10:04:35 foxr Exp $
+# $Id: lonnet.pm,v 1.950 2008/03/22 15:47:41 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -448,27 +448,39 @@ sub timed_flock {
# ---------------------------------------------------------- Append Environment
sub appenv {
- my %newenv=@_;
- foreach my $key (keys(%newenv)) {
- if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
- &logthis("WARNING: ".
- "Attempt to modify environment ".$key." to ".$newenv{$key}
- .'');
- delete($newenv{$key});
- } else {
- $env{$key}=$newenv{$key};
+ my ($newenv,$roles) = @_;
+ if (ref($newenv) eq 'HASH') {
+ foreach my $key (keys(%{$newenv})) {
+ my $refused = 0;
+ if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
+ $refused = 1;
+ if (ref($roles) eq 'ARRAY') {
+ my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
+ if (grep(/^\Q$role\E$/,@{$roles})) {
+ $refused = 0;
+ }
+ }
+ }
+ if ($refused) {
+ &logthis("WARNING: ".
+ "Attempt to modify environment ".$key." to ".$newenv->{$key}
+ .'');
+ 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';
}
@@ -1064,6 +1076,10 @@ sub inst_rulecheck {
$response=&unescape(&reply('instidrulecheck:'.&escape($udom).
':'.&escape($id).':'.$rulestr,
$homeserver));
+ } elsif ($item eq 'selfcreate') {
+ $response=&unescape(&reply('instselfcreatecheck:'.
+ &escape($udom).':'.&escape($uname).
+ ':'.$rulestr,$homeserver));
}
if ($response ne 'refused') {
my @pairs=split(/\&/,$response);
@@ -1090,6 +1106,9 @@ sub inst_userrules {
if ($check eq 'id') {
$response=&reply('instidrules:'.&escape($udom),
$homeserver);
+ } elsif ($check eq 'email') {
+ $response=&reply('instemailrules:'.&escape($udom),
+ $homeserver);
} else {
$response=&reply('instuserrules:'.&escape($udom),
$homeserver);
@@ -1115,6 +1134,35 @@ sub inst_userrules {
return (\%ruleshash,\@ruleorder);
}
+# ------------------------- Get Authentication and Language Defaults for Domain
+
+sub get_domain_defaults {
+ my ($domain) = @_;
+ my $cachetime = 60*60*24;
+ my ($defauthtype,$defautharg,$deflang);
+ my ($result,$cached)=&is_cached_new('domdefaults',$domain);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ return %{$result};
+ }
+ }
+ my %domdefaults;
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['defaults'],$domain);
+ if (ref($domconfig{'defaults'}) eq 'HASH') {
+ $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
+ $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
+ $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+ } else {
+ $domdefaults{'lang_def'} = &domain($domain,'lang_def');
+ $domdefaults{'auth_def'} = &domain($domain,'auth_def');
+ $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
+ }
+ &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
+ $cachetime);
+ return %domdefaults;
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -1147,7 +1195,7 @@ sub assign_access_key {
# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {
- &appenv('environment.'.$envkey => $ckey);
+ &appenv({'environment.'.$envkey => $ckey});
return 'ok';
} else {
return
@@ -1656,18 +1704,14 @@ sub absolute_url {
# fn Possibly encrypted resource name/id.
# form Hash that describes how the rendering should be done
# and other things.
-# r Optional reference that will be given the response.
-# This is mostly provided so that the caller can implement
-# error detection, recovery and retry policies.
-#
# Returns:
-# The content of the response.
+# Scalar context: The content of the response.
+# Array context: 2 element list of the content and the full response object.
+#
sub ssi {
- my ($fn,%form, $r)=@_;
-
+ my ($fn,%form)=@_;
my $ua=new LWP::UserAgent;
-
my $request;
$form{'no_update_last_known'}=1;
@@ -1682,11 +1726,11 @@ sub ssi {
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $response=$ua->request($request);
- if ($r) {
- $$r = $response;
+ if (wantarray) {
+ return ($response->content, $response);
+ } else {
+ return $response->content;
}
-
- return $response->content;
}
sub externalssi {
@@ -1707,7 +1751,7 @@ sub allowuploaded {
my %httpref=();
my $httpurl=&hreflocation('',$url);
$httpref{'httpref.'.$httpurl}=$srcurl;
- &Apache::lonnet::appenv(%httpref);
+ &Apache::lonnet::appenv(\%httpref);
}
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
@@ -2410,7 +2454,7 @@ sub userrolelog {
}
sub get_course_adv_roles {
- my $cid=shift;
+ my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
my %nothide=();
@@ -2435,14 +2479,23 @@ sub get_course_adv_roles {
if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
- my $key=&plaintext($role);
- if ($section) { $key.=' (Sec/Grp '.$section.')'; }
- if ($returnhash{$key}) {
- $returnhash{$key}.=','.$username.':'.$domain;
+ if ($codes) {
+ if ($section) { $role .= ':'.$section; }
+ if ($returnhash{$role}) {
+ $returnhash{$role}.=','.$username.':'.$domain;
+ } else {
+ $returnhash{$role}=$username.':'.$domain;
+ }
} 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;
}
@@ -2604,7 +2657,8 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
- $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
+ $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
+ $selfenrollonly)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -2621,7 +2675,8 @@ sub courseiddump {
$sincefilter.':'.&escape($descfilter).':'.
&escape($instcodefilter).':'.&escape($ownerfilter).
':'.&escape($coursefilter).':'.&escape($typefilter).
- ':'.&escape($regexp_ok).':'.$as_hash,$tryserver);
+ ':'.&escape($regexp_ok).':'.$as_hash.':'.
+ &escape($selfenrollonly),$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3358,7 +3413,7 @@ sub coursedescription {
}
}
if (!$args->{'one_time'}) {
- &appenv(%envhash);
+ &appenv(\%envhash);
}
return %returnhash;
}
@@ -5273,7 +5328,7 @@ sub plaintext {
# ----------------------------------------------------------------- Assign Role
sub assignrole {
- my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
+ my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_;
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
@@ -5307,11 +5362,15 @@ sub assignrole {
} else {
$refused = 1;
}
- if ($refused) {
- &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
- ' '.$role.' '.$end.' '.$start.' by '.
- $env{'user.name'}.' at '.$env{'user.domain'});
- return 'refused';
+ if ($refused) {
+ if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ $refused = '';
+ } else {
+ &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
+ ' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
}
}
$mrole=$role;
@@ -5505,7 +5564,7 @@ sub modifystudent {
}
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);
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
@@ -5563,7 +5622,7 @@ sub modify_student_enrollment {
if ($usec) {
$uurl.='/'.$usec;
}
- return &assignrole($udom,$uname,$uurl,'st',$end,$start);
+ return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll);
}
sub format_name {
@@ -5682,7 +5741,7 @@ ENDINITMAP
sub is_course {
my ($cdom,$cnum) = @_;
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
- undef,'.',undef,1);
+ undef,'.');
if (exists($courses{$cdom.'_'.$cnum})) {
return 1;
}
@@ -6297,7 +6356,7 @@ sub directcondval {
untie(%bighash);
}
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;
}
if ($env{'user.state.'.$env{'request.course.id'}}) {
@@ -6483,7 +6542,7 @@ sub EXT_cache_status {
sub EXT_cache_set {
my ($target_domain,$target_user) = @_;
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
- #&appenv($cachename => time);
+ #&appenv({$cachename => time});
}
# --------------------------------------------------------- Value of a Variable
@@ -7385,7 +7444,7 @@ sub symbread {
if ($syval) {
#unless ($syval=~/\_\d+$/) {
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
- #&appenv('request.ambiguous' => $thisfn);
+ #&appenv({'request.ambiguous' => $thisfn});
#return $env{$cache_str}='';
#}
#$syval.=$1;
@@ -7437,7 +7496,7 @@ sub symbread {
return $env{$cache_str}=$syval;
}
}
- &appenv('request.ambiguous' => $thisfn);
+ &appenv({'request.ambiguous' => $thisfn});
return $env{$cache_str}='';
}
@@ -7951,7 +8010,7 @@ sub tokenwrapper {
my (undef,$udom,$uname,$file)=split('/',$uri,4);
if ($udom && $uname && $file) {
$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.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
@@ -8796,10 +8855,12 @@ that was requested
=item *
X
-B: the value of %hash is written to
+B: the value of %{$hashref} is written to
the user envirnoment file, and will be restored for each access this
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 *
X
@@ -9362,6 +9423,18 @@ put_dom($namespace,$storehash,$udom,$uho
domain level either on specified domain server ($uhome) or primary domain
server ($udom and $uhome are optional)
+=item *
+
+get_domain_defaults($target_domain) : returns hash with defaults for
+authentication and language in the domain. Keys are: auth_def, auth_arg_def,
+lang_def; corresponsing values are authentication type (internal, krb4, krb5,
+or localauth), initial password or a kerberos realm, language (e.g., en-us).
+Values are retrieved from cache (if current), or from domain's configuration.db
+(if available), or lastly from values in lonTabs/dns_domain,tab,
+or lonTabs/domain.tab.
+
+%domdefaults = &get_auth_defaults($target_domain);
+
=back
=head2 Network Status Functions