--- loncom/lonnet/perl/lonnet.pm 2004/06/08 22:09:44 1.506
+++ loncom/lonnet/perl/lonnet.pm 2004/07/06 18:02:33 1.521
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.506 2004/06/08 22:09:44 raeburn Exp $
+# $Id: lonnet.pm,v 1.521 2004/07/06 18:02:33 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -38,7 +38,7 @@ use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount
- %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache
+ %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
@@ -1395,10 +1395,12 @@ sub flushcourselogs {
}
if ($courseidbuffer{$coursehombuf{$crsid}}) {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.
- &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+ &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
+ '='.&escape($courseinstcodebuf{$crsid});
} else {
$courseidbuffer{$coursehombuf{$crsid}}=
- &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+ &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
+ '='.&escape($courseinstcodebuf{$crsid});
}
}
#
@@ -1472,6 +1474,8 @@ sub courselog {
$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
$coursedescrbuf{$ENV{'request.course.id'}}=
$ENV{'course.'.$ENV{'request.course.id'}.'.description'};
+ $courseinstcodebuf{$ENV{'request.course.id'}}=
+ $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
if (defined $courselogs{$ENV{'request.course.id'}}) {
$courselogs{$ENV{'request.course.id'}}.='&'.$what;
} else {
@@ -1596,7 +1600,7 @@ sub getannounce {
if ($announcement=~/\w/) {
return
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
- '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';
+ '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>';
} else {
return '';
}
@@ -1615,11 +1619,11 @@ sub courseidput {
}
sub courseiddump {
- my ($domfilter,$descfilter,$sincefilter,$hostid)=@_;
+ my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;
my %returnhash=();
unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {
- if (($hostid && $tryserver eq $hostid) || (!$hostid)) {
+ if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
foreach (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
@@ -1627,7 +1631,7 @@ sub courseiddump {
$tryserver))) {
my ($key,$value)=split(/\=/,$_);
if (($key) && ($value)) {
- $returnhash{&unescape($key)}=&unescape($value);
+ $returnhash{&unescape($key)}=$value;
}
}
}
@@ -3054,14 +3058,20 @@ sub log_query {
return get_query_reply($queryid);
}
-# ------- Request retrieval of institutional classlists from course homerserver
+# ------- Request retrieval of institutional classlists for course(s)
sub fetch_enrollment_query {
- my ($homeserver,$dom,$affiliatesref,$replyref) = @_;
+ my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
+ my $homeserver;
+ if ($context eq 'automated') {
+ $homeserver = $perlvar{'lonHostID'};
+ } else {
+ $homeserver = &homeserver($cnum,$dom);
+ }
my $host=$hostname{$homeserver};
my $cmd = '';
foreach (keys %{$affiliatesref}) {
- $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
+ $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
}
$cmd =~ s/%%$//;
$cmd = &escape($cmd);
@@ -3070,8 +3080,13 @@ sub fetch_enrollment_query {
unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }
my $reply = &get_query_reply($queryid);
unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
- unless ($homeserver eq $perlvar{'lonHostID'}) {
- my @responses = split/:/,$reply;
+ my @responses = split/:/,$reply;
+ if ($homeserver eq $perlvar{'lonHostID'}) {
+ foreach (@responses) {
+ my ($key,$value) = split/=/,$_;
+ $$replyref{$key} = $value;
+ }
+ } else {
my $pathname = $perlvar{'lonDaemons'}.'/tmp';
foreach (@responses) {
my ($key,$value) = split/=/,$_;
@@ -3143,15 +3158,17 @@ sub userlog_query {
#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course
sub auto_run {
- my $homeserver = shift;
- my $response = &reply('autorun',$homeserver);
+ my ($cnum,$cdom) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $response = &reply('autorun:'.$cdom,$homeserver);
return $response;
}
sub auto_get_sections {
- my ($homeserver,$coursecode) = @_;
+ my ($cnum,$cdom,$inst_coursecode) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
my @secs = ();
- my $response=&unescape(&reply('autogetsections:'.$coursecode,$homeserver));
+ my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
unless ($response eq 'refused') {
@secs = split/:/,$response;
}
@@ -3159,22 +3176,25 @@ sub auto_get_sections {
}
sub auto_new_course {
- my ($homeserver,$course_id,$owner) = @_;
- my $response=&unescape(&reply('autonewcourse:'.$course_id.':'.$owner,$homeserver));
+ my ($cnum,$cdom,$inst_course_id,$owner) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
return $response;
}
sub auto_validate_courseID {
- my ($homeserver,$course_id) = @_;
- my $response=&unescape(&reply('autovalidatecourse:'.$course_id,$homeserver));
+ my ($cnum,$cdom,$inst_course_id) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
return $response;
}
sub auto_create_password {
- my ($homeserver,$authparam) = @_;
+ my ($cnum,$cdom,$authparam) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
my $create_passwd = 0;
my $authchk = '';
- my $response=&unescape(&reply('autocreatepassword:'.$authparam,$homeserver));
+ my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
if ($response eq 'refused') {
$authchk = 'refused';
} else {
@@ -3183,6 +3203,32 @@ sub auto_create_password {
return ($authparam,$create_passwd,$authchk);
}
+sub auto_instcode_format {
+ my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
+ my $courses = '';
+ my $homeserver;
+ if ($caller eq 'global') {
+ $homeserver = $perlvar{'lonHostID'};
+ } else {
+ $homeserver = &homeserver($caller,$codedom);
+ }
+ my $host=$hostname{$homeserver};
+ foreach (keys %{$instcodes}) {
+ $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
+ }
+ chop($courses);
+ my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+ my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
+ %{$codes} = &str2hash($codes_str);
+ @{$codetitles} = &str2array($codetitles_str);
+ %{$cat_titles} = &str2hash($cat_titles_str);
+ %{$cat_order} = &str2hash($cat_order_str);
+ return 'ok';
+ }
+ return $response;
+}
+
# ------------------------------------------------------------------ Plain Text
sub plaintext {
@@ -3373,7 +3419,7 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
- $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
+ $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';
@@ -3388,13 +3434,12 @@ sub modifystudent {
# students environment
$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
- $gene,$usec,$end,$start,$type,$cid);
+ $gene,$usec,$end,$start,$type,$locktype,$cid);
return $reply;
}
sub modify_student_enrollment {
- my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
- $cid) = @_;
+ my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
my ($cdom,$cnum,$chome);
if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {
@@ -3440,7 +3485,7 @@ sub modify_student_enrollment {
$first,$middle);
my $reply=cput('classlist',
{"$uname:$udom" =>
- join(':',$end,$start,$uid,$usec,$fullname,$type) },
+ join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
$cdom,$cnum);
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return 'error: '.$reply;
@@ -3476,7 +3521,7 @@ sub writecoursepref {
# ---------------------------------------------------------- Make/modify course
sub createcourse {
- my ($udom,$description,$url,$course_server,$nonstandard)=@_;
+ my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;
$url=&declutter($url);
my $cid='';
unless (&allowed('ccc',$udom)) {
@@ -3509,9 +3554,9 @@ sub createcourse {
return 'error: no such course';
}
# ----------------------------------------------------------------- Course made
-# log existance
- &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),
- $uhome);
+# log existence
+ &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
+ '='.&escape($inst_code),$uhome);
&flushcourselogs();
# set toplevel url
my $topurl=$url;
@@ -3564,6 +3609,42 @@ sub revokecustomrole {
$deleteflag);
}
+
+# ------------------------------------------------------------ Portfolio Director Lister
+# returns listing of contents of user's /userfiles/portfolio/ directory
+#
+
+sub portfoliolist {
+ my ($currentPath, $currentFile) = @_;
+ my ($udom, $uname, $portfolioRoot);
+ $uname=$ENV{'user.name'};
+ $udom=$ENV{'user.domain'};
+ # really should interrogate the system for home directory information, but . . .
+ $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';
+ $uname =~ /^(.?)(.?)(.?)/;
+ $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';
+ my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));
+ return $listing;
+}
+
+sub portfoliomanage {
+
+#FIXME please user the existing remove userfile function instead and
+#add a userfilerename functions.
+#FIXME uhome should never be an argument to any lonnet functions
+
+ # handles deleting and renaming files in user's userfiles/portfolio/ directory
+ #
+ my ($filename, $fileaction, $filenewname) = @_;
+ my ($udom, $uname, $uhome);
+ $uname=$ENV{'user.name'};
+ $udom=$ENV{'user.domain'};
+ $uhome=$ENV{'user.home'};
+ my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);
+ return $listing;
+}
+
+
# ------------------------------------------------------------ Directory lister
sub dirlist {
@@ -4359,7 +4440,10 @@ sub symblist {
# --------------------------------------------------------------- Verify a symb
sub symbverify {
- my ($symb,$thisfn)=@_;
+ my ($symb,$thisurl)=@_;
+ my $thisfn=$thisurl;
+# wrapper not part of symbs
+ $thisfn=~s/^\/adm\/wrapper//;
$thisfn=&declutter($thisfn);
# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page|sequence)$/) { return 1; }
@@ -4369,6 +4453,7 @@ sub symbverify {
unless ($url eq $thisfn) { return 0; }
$symb=&symbclean($symb);
+ $thisurl=&deversion($thisurl);
$thisfn=&deversion($thisfn);
my %bighash;
@@ -4376,9 +4461,9 @@ sub symbverify {
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {
- my $ids=$bighash{'ids_'.&clutter($thisfn)};
+ my $ids=$bighash{'ids_'.&clutter($thisurl)};
unless ($ids) {
- $ids=$bighash{'ids_/'.$thisfn};
+ $ids=$bighash{'ids_/'.$thisurl};
}
if ($ids) {
# ------------------------------------------------------------------- Has ID(s)
@@ -4407,6 +4492,9 @@ sub symbclean {
# remove version from URL
$symb=~s/\.(\d+)\.(\w+)$/\.$2/;
+# remove wrapper
+
+ $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
return $symb;
}
@@ -4820,6 +4908,14 @@ sub getfile {
if ($rtncode eq '404') {
unlink($localfile);
}
+ #my $ua=new LWP::UserAgent;
+ #my $request=new HTTP::Request('GET',&tokenwrapper($file));
+ #my $response=$ua->request($request);
+ #if ($response->is_success()) {
+ # return $response->content;
+ # } else {
+ # return -1;
+ # }
return -1;
}
if ($info < $fileinfo[9]) {
@@ -4832,13 +4928,21 @@ sub getfile {
}
} else {
$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
+ &logthis("return is $lwpresp");
if ($lwpresp ne 'ok') {
- return -1;
+ my $ua=new LWP::UserAgent;
+ my $request=new HTTP::Request('GET',&tokenwrapper($file));
+ my $response=$ua->request($request);
+ if ($response->is_success()) {
+ return $response->content;
+ } else {
+ return -1;
+ }
}
my @parts = ($cdom,$cnum);
if ($filename =~ m|^(.+)/[^/]+$|) {
push @parts, split(/\//,$1);
- }
+ }
foreach my $part (@parts) {
$path .= '/'.$part;
if (!-e $path) {
@@ -4855,6 +4959,22 @@ sub getfile {
return $info;
}
+sub tokenwrapper {
+ my $uri=shift;
+ $uri=~s/^http\:\/\/([^\/]+)//;
+ $uri=~s/^\///;
+ $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
+ my $token=$1;
+ if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
+ &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
+ return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
+ (($uri=~/\?/)?'&':'?').'token='.$token.
+ '&tokenissued='.$perlvar{'lonHostID'};
+ } else {
+ return '/adm/notfound.html';
+ }
+}
+
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
@@ -4962,7 +5082,7 @@ sub declutter {
sub clutter {
my $thisfn='/'.&declutter(shift);
- unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) {
+ unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) {
$thisfn='/res'.$thisfn;
}
return $thisfn;