--- loncom/lonnet/perl/lonnet.pm 2009/07/17 13:55:10 1.1004
+++ loncom/lonnet/perl/lonnet.pm 2009/08/16 21:49:32 1.1018
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1004 2009/07/17 13:55:10 droeschl Exp $
+# $Id: lonnet.pm,v 1.1018 2009/08/16 21:49:32 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -958,6 +958,43 @@ sub idput {
}
}
+# ------------------------------------------------ dump from domain db files
+
+sub dump_dom {
+ my ($namespace,$udom,$uhome,$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);
+ }
+ }
+ return %returnhash;
+}
+
# ------------------------------------------- get items from domain db files
sub get_dom {
@@ -1032,6 +1069,70 @@ sub put_dom {
}
}
+# -------------------------------------- newput for items in domain db files
+
+sub newput_dom {
+ my ($namespace,$storehash,$udom,$uhome) = @_;
+ 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");
+ }
+ return $result;
+}
+
+sub del_dom {
+ my ($namespace,$storearr,$udom,$uhome)=@_;
+ 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");
+ }
+ }
+}
+
sub retrieve_inst_usertypes {
my ($udom) = @_;
my (%returnhash,@order);
@@ -1326,7 +1427,7 @@ sub get_domain_defaults {
}
}
if (ref($domconfig{'requestcourses'}) eq 'HASH') {
- foreach my $item ('official','unofficial') {
+ foreach my $item ('official','unofficial','community') {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}
}
@@ -1665,12 +1766,14 @@ sub userenvironment {
}
$items=~s/\&$//;
my %returnhash=();
- my @answer=split(/\&/,
- &reply('get:'.$udom.':'.$unam.':environment:'.$items,
- &homeserver($unam,$udom)));
- my $i;
- for ($i=0;$i<=$#what;$i++) {
- $returnhash{$what[$i]}=&unescape($answer[$i]);
+ my $uhome = &homeserver($unam,$udom);
+ unless ($uhome eq 'no_host') {
+ my @answer=split(/\&/,
+ &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
+ my $i;
+ for ($i=0;$i<=$#what;$i++) {
+ $returnhash{$what[$i]}=&unescape($answer[$i]);
+ }
}
return %returnhash;
}
@@ -2968,7 +3071,7 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
- $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
+ $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,$cloneonly)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -2987,7 +3090,8 @@ sub courseiddump {
':'.&escape($coursefilter).':'.&escape($typefilter).
':'.&escape($regexp_ok).':'.$as_hash.':'.
&escape($selfenrollonly).':'.&escape($catfilter).':'.
- $showhidden.':'.$caller,$tryserver);
+ $showhidden.':'.$caller.':'.&escape($cloner).':'.
+ &escape($cc_clone).':'.$cloneonly,$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3002,7 +3106,7 @@ sub courseiddump {
for (my $i=0; $i<@responses; $i++) {
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
}
- }
+ }
}
}
}
@@ -3042,10 +3146,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;
@@ -4635,6 +4739,7 @@ sub usertools_access {
%tools = (
official => 1,
unofficial => 1,
+ community => 1,
);
} else {
%tools = (
@@ -5506,11 +5611,21 @@ sub auto_run {
sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;
- my $homeserver = &homeserver($cnum,$cdom);
- my @secs = ();
- my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
- unless ($response eq 'refused') {
- @secs = split(/:/,$response);
+ my $homeserver;
+ if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ }
+ if (!defined($homeserver)) {
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ }
+ my @secs;
+ if (defined($homeserver)) {
+ my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
+ unless ($response eq 'refused') {
+ @secs = split(/:/,$response);
+ }
}
return @secs;
}
@@ -5529,6 +5644,22 @@ sub auto_validate_courseID {
return $response;
}
+sub auto_validate_instcode {
+ my ($cnum,$cdom,$instcode,$owner) = @_;
+ my ($homeserver,$response);
+ if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ }
+ if (!defined($homeserver)) {
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ }
+ my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
+ &escape($instcode).':'.&escape($owner),$homeserver));
+ return $response;
+}
+
sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);
@@ -5703,7 +5834,11 @@ sub auto_instcode_defaults {
}
sub auto_possible_instcodes {
- my ($domain,$codetitles,$cat_titles,$cat_order) = @_;
+ my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
+ unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') &&
+ (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
+ return;
+ }
my (@homeservers,$uhome);
if (defined(&domain($domain,'primary'))) {
$uhome=&domain($domain,'primary');
@@ -5720,21 +5855,34 @@ sub auto_possible_instcodes {
foreach my $server (@homeservers) {
$response=&reply('autopossibleinstcodes:'.$domain,$server);
next if ($response =~ /(con_lost|error|no_such_host|refused)/);
- my ($codetitlestr,$cat_title,$cat_order) = split(':',$response);
- @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
+ my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) =
+ split(':',$response);
+ @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
+ @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
foreach my $item (split('&',$cat_title)) {
- my ($name,$value)=split('&',$item);
- $cat_titles->{&unescape($name)}=&unescape($value);
+ my ($name,$value)=split('=',$item);
+ $cat_titles->{&unescape($name)}=&thaw_unescape($value);
}
foreach my $item (split('&',$cat_order)) {
- my ($name,$value)=split('&',$item);
- $cat_order->{&unescape($name)}=&unescape($value);
+ my ($name,$value)=split('=',$item);
+ $cat_orders->{&unescape($name)}=&thaw_unescape($value);
}
return 'ok';
}
return $response;
}
+sub auto_courserequest_checks {
+ my ($dom) = @_;
+ my %validations;
+ return %validations;
+}
+
+sub auto_courserequest_validation {
+ my ($dom,$details,$inststatuses,$message) = @_;
+ return 'pending';
+}
+
sub auto_validate_class_sec {
my ($cdom,$cnum,$owners,$inst_class) = @_;
my $homeserver = &homeserver($cnum,$cdom);
@@ -5901,8 +6049,8 @@ sub plaintext {
}
}
my %rolenames = (
- Course => 'std',
- Group => 'alt1',
+ Course => 'std',
+ Community => 'alt1',
);
if (defined($type) &&
defined($rolenames{$type}) &&
@@ -5954,7 +6102,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'});
@@ -6278,28 +6436,32 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype)=@_;
+ $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';
+ }
}
-# ------------------------------------------------------------------- Create ID
- my $uname=int(1+rand(9)).
- ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
- substr($$.time,0,5).unpack("H8",pack("I32",time)).
- unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
-# ----------------------------------------------- Make sure that does not exist
- my $uhome=&homeserver($uname,$udom,'true');
- unless (($uhome eq '') || ($uhome eq 'no_host')) {
- $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
- unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
- $uhome=&homeserver($uname,$udom,'true');
- unless (($uhome eq '') || ($uhome eq 'no_host')) {
- return 'error: unable to generate unique course-ID';
- }
- }
-# ------------------------------------------------ Check supplied server name
+# --------------------------------------------------------------- Get Unique ID
+ my $uname;
+ if ($cnum =~ /^$match_courseid$/) {
+ my $chome=&homeserver($cnum,$udom,'true');
+ if (($chome eq '') || ($chome eq 'no_host')) {
+ $uname = $cnum;
+ } else {
+ $uname = &generate_coursenum($udom);
+ }
+ } else {
+ $uname = &generate_coursenum($udom);
+ }
+ return $uname if ($uname =~ /^error/);
+# -------------------------------------------------- Check supplied server name
$course_server = $env{'user.homeserver'} if (! defined($course_server));
if (! &is_library($course_server)) {
return 'error:bad server name '.$course_server;
@@ -6308,7 +6470,7 @@ sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$course_server);
unless ($reply eq 'ok') { return 'error: '.$reply; }
- $uhome=&homeserver($uname,$udom,'true');
+ my $uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such course';
}
@@ -6349,6 +6511,30 @@ ENDINITMAP
return '/'.$udom.'/'.$uname;
}
+# ------------------------------------------------------------------- Create ID
+sub generate_coursenum {
+ my ($udom) = @_;
+ my $domdesc = &domain($udom);
+ return 'error: invalid domain' if ($domdesc eq '');
+ my $uname=int(1+rand(9)).
+ ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+ substr($$.time,0,5).unpack("H8",pack("I32",time)).
+ unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+# ----------------------------------------------- Make sure that does not exist
+ my $uhome=&homeserver($uname,$udom,'true');
+ unless (($uhome eq '') || ($uhome eq 'no_host')) {
+ $uname=int(1+rand(9)).
+ ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+ substr($$.time,0,5).unpack("H8",pack("I32",time)).
+ unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+ $uhome=&homeserver($uname,$udom,'true');
+ unless (($uhome eq '') || ($uhome eq 'no_host')) {
+ return 'error: unable to generate unique course-ID';
+ }
+ }
+ return $uname;
+}
+
sub is_course {
my ($cdom,$cnum) = @_;
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
@@ -6359,6 +6545,39 @@ sub is_course {
return 0;
}
+sub store_userdata {
+ my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
+ my $result;
+ if ($datakey ne '') {
+ if (ref($storehash) eq 'HASH') {
+ 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 {
+ $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
+ $storehash->{'host'} = $perlvar{'lonHostID'};
+
+ my $namevalue='';
+ foreach my $key (keys(%{$storehash})) {
+ $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
+ }
+ $namevalue=~s/\&$//;
+ $result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
+ "$namespace:$datakey:$namevalue",$uhome);
+ }
+ } else {
+ $result = 'error: data to store was not a hash reference';
+ }
+ } else {
+ $result= 'error: invalid requestkey';
+ }
+ return $result;
+}
+
# ---------------------------------------------------------- Assign Custom Role
sub assigncustomrole {
@@ -7848,6 +8067,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 {
@@ -9661,7 +9885,7 @@ and course level
plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash
(rolesplain.tab); plain text explanation of a user role term.
-$type is Course (default) or Group.
+$type is Course (default) or Community.
If $forcedefault evaluates to true, text returned will be default
text for $type. Otherwise, if this is a course, the text returned
will be a custom name for the role (if defined in the course's
@@ -9871,7 +10095,11 @@ database) for a course
=item *
-createcourse($udom,$description,$url) : make/modify course
+createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
+
+=item *
+
+generate_coursenum($udom) : get a unique (unused) course number in domain $udom
=back