--- loncom/lonnet/perl/lonnet.pm 2009/07/31 02:20:17 1.1008
+++ loncom/lonnet/perl/lonnet.pm 2009/08/11 11:33:52 1.1014
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1008 2009/07/31 02:20:17 raeburn Exp $
+# $Id: lonnet.pm,v 1.1014 2009/08/11 11:33:52 droeschl 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);
@@ -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;
}
@@ -5769,6 +5872,17 @@ sub auto_possible_instcodes {
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);
@@ -6312,28 +6426,26 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype)=@_;
+ $course_owner,$crstype,$cnum)=@_;
$url=&declutter($url);
my $cid='';
unless (&allowed('ccc',$udom)) {
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;
@@ -6342,7 +6454,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';
}
@@ -6383,6 +6495,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,
@@ -6393,6 +6529,36 @@ sub is_course {
return 0;
}
+sub store_coursereq {
+ my ($requestkey,$storehash) = @_;
+ my $result;
+ if ($requestkey =~ /^($match_domain)_($match_courseid)$/) {
+ if (ref($storehash) eq 'HASH') {
+ my $namespace = 'courserequests';
+ my $uhome=&homeserver();
+ 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:$requestkey:$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 {
@@ -7882,6 +8048,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 {
@@ -9905,7 +10076,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