--- loncom/lonnet/perl/lonnet.pm 2009/08/11 01:39:44 1.1013
+++ loncom/lonnet/perl/lonnet.pm 2009/08/24 20:08:40 1.1023
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1013 2009/08/11 01:39:44 raeburn Exp $
+# $Id: lonnet.pm,v 1.1023 2009/08/24 20:08:40 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -958,44 +958,21 @@ sub idput {
}
}
-# ------------------------------------------------ dump from domain db files
-
+# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {
- my ($namespace,$udom,$uhome,$regexp,$range)=@_;
+ my ($namespace,$udom,$regexp,$range)=@_;
if (!$udom) {
$udom=$env{'user.domain'};
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- } else {
- undef($uhome);
- }
- } else {
- if (!$uhome) {
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- }
- }
}
my %returnhash;
- if ($udom && $uhome && ($uhome ne 'no_host')) {
- if ($regexp) {
- $regexp=&escape($regexp);
- } else {
- $regexp='.';
- }
- my $rep=&reply("dumpdom:$udom:$namespace:$regexp:$range",$uhome);
- my @pairs=split(/\&/,$rep);
- foreach my $item (@pairs) {
- my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key);
- next if ($key =~ /^error: 2 /);
- $returnhash{$key}=&thaw_unescape($value);
- }
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
}
return %returnhash;
}
-# ------------------------------------------- get items from domain db files
+# ------------------------------------------ get items from domain db files
sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;
@@ -1069,70 +1046,40 @@ sub put_dom {
}
}
-# -------------------------------------- newput for items in domain db files
-
+# --------------------- newput for items in db file owned by domainconfig user
sub newput_dom {
- my ($namespace,$storehash,$udom,$uhome) = @_;
+ my ($namespace,$storehash,$udom) = @_;
my $result;
if (!$udom) {
$udom=$env{'user.domain'};
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- } else {
- undef($uhome);
- }
- } else {
- if (!$uhome) {
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- }
- }
}
- if ($udom && $uhome && ($uhome ne 'no_host')) {
- my $items='';
- if (ref($storehash) eq 'HASH') {
- foreach my $key (keys(%$storehash)) {
- $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
- }
- $items=~s/\&$//;
- $result = &reply("newputdom:$udom:$namespace:$items",$uhome);
- }
- } else {
- &logthis("put_dom failed - no homeserver and/or domain");
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ $result = &newput($namespace,$storehash,$udom,$uname);
}
return $result;
}
+# --------------------- delete for items in db file owned by domainconfig user
sub del_dom {
- my ($namespace,$storearr,$udom,$uhome)=@_;
+ my ($namespace,$storearr,$udom)=@_;
if (ref($storearr) eq 'ARRAY') {
- my $items='';
- foreach my $item (@$storearr) {
- $items.=&escape($item).'&';
- }
- $items=~s/\&$//;
if (!$udom) {
$udom=$env{'user.domain'};
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- } else {
- undef($uhome);
- }
- } else {
- if (!$uhome) {
- if (defined(&domain($udom,'primary'))) {
- $uhome=&domain($udom,'primary');
- }
- }
}
- if ($udom && $uhome && ($uhome ne 'no_host')) {
- return &reply("deldom:$udom:$namespace:$items",$uhome);
- } else {
- &logthis("del_dom failed - no homeserver and/or domain");
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ return &del($namespace,$storearr,$udom,$uname);
}
}
}
+# ----------------------------------construct domainconfig user for a domain
+sub get_domainconfiguser {
+ my ($udom) = @_;
+ return $udom.'-domainconfig';
+}
+
sub retrieve_inst_usertypes {
my ($udom) = @_;
my (%returnhash,@order);
@@ -3146,10 +3093,10 @@ sub dcmaildump {
sub get_domain_roles {
my ($dom,$roles,$startdate,$enddate)=@_;
- if (undef($startdate) || $startdate eq '') {
+ if ((!defined($startdate)) || ($startdate eq '')) {
$startdate = '.';
}
- if (undef($enddate) || $enddate eq '') {
+ if ((!defined($enddate)) || ($enddate eq '')) {
$enddate = '.';
}
my $rolelist;
@@ -5774,6 +5721,13 @@ sub auto_instcode_format {
push(@homeservers,$tryserver);
}
}
+ } elsif ($caller eq 'requests') {
+ if ($codedom =~ /^$match_domain$/) {
+ my $chome = &domain($codedom,'primary');
+ unless ($chome eq 'no_host') {
+ push(@homeservers,$chome);
+ }
+ }
} else {
push(@homeservers,&homeserver($caller,$codedom));
}
@@ -5874,13 +5828,37 @@ sub auto_possible_instcodes {
sub auto_courserequest_checks {
my ($dom) = @_;
- my %validations;
+ my ($homeserver,%validations);
+ if ($dom =~ /^$match_domain$/) {
+ $homeserver = &domain($dom,'primary');
+ }
+ unless ($homeserver eq 'no_host') {
+ my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+ my @items = split(/&/,$response);
+ foreach my $item (@items) {
+ my ($key,$value) = split('=',$item);
+ $validations{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
return %validations;
}
sub auto_courserequest_validation {
- my ($dom,$details,$inststatuses,$message) = @_;
- return 'pending';
+ my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
+ my ($homeserver,$response);
+ if ($dom =~ /^$match_domain$/) {
+ $homeserver = &domain($dom,'primary');
+ }
+ unless ($homeserver eq 'no_host') {
+
+ $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
+ ':'.&escape($crstype).':'.&escape($inststatuslist).
+ ':'.&escape($instcode).':'.&escape($instseclist),
+ $homeserver));
+ }
+ return $response;
}
sub auto_validate_class_sec {
@@ -6102,7 +6080,17 @@ sub assignrole {
if ($refused) {
if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';
- } else {
+ } elsif ($context eq 'requestcourses') {
+ if (($role eq 'cc') && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
+ my ($cdom,$cnum) = ($cwosec =~ m{^/($match_domain)/($match_courseid)$});
+ my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ }
+ if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
' '.$role.' '.$end.' '.$start.' by '.
$env{'user.name'}.' at '.$env{'user.domain'});
@@ -6426,11 +6414,17 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype,$cnum)=@_;
+ $course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);
my $cid='';
unless (&allowed('ccc',$udom)) {
- return 'refused';
+ if ($context eq 'requestcourses') {
+ unless (&usertools_access($course_owner,$udom,$category,undef,$context)) {
+ return 'refused';
+ }
+ } else {
+ return 'refused';
+ }
}
# --------------------------------------------------------------- Get Unique ID
my $uname;
@@ -6529,13 +6523,16 @@ sub is_course {
return 0;
}
-sub store_coursereq {
- my ($requestkey,$storehash) = @_;
+sub store_userdata {
+ my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
my $result;
- if ($requestkey =~ /^($match_domain)_($match_courseid)$/) {
+ if ($datakey ne '') {
if (ref($storehash) eq 'HASH') {
- my $namespace = 'courserequests';
- my $uhome=&homeserver();
+ if ($udom eq '' || $uname eq '') {
+ $udom = $env{'user.domain'};
+ $uname = $env{'user.name'};
+ }
+ my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
$result = 'error: no_host';
} else {
@@ -6548,7 +6545,7 @@ sub store_coursereq {
}
$namevalue=~s/\&$//;
$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
- "$namespace:$requestkey:$namevalue",$uhome);
+ "$namespace:$datakey:$namevalue",$uhome);
}
} else {
$result = 'error: data to store was not a hash reference';
@@ -8048,6 +8045,11 @@ sub devalidate_title_cache {
&devalidate_cache_new('title',$key);
}
+# ------------------------------------------------- Get the title of a course
+
+sub current_course_title {
+ return $env{ 'course.' . $env{'request.course.id'} . '.description' };
+}
# ------------------------------------------------- Get the title of a resource
sub gettitle {