--- loncom/lonnet/perl/lonnet.pm 2004/06/17 18:31:25 1.511 +++ loncom/lonnet/perl/lonnet.pm 2004/07/02 21:34:55 1.519 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.511 2004/06/17 18:31:25 raeburn Exp $ +# $Id: lonnet.pm,v 1.519 2004/07/02 21:34:55 banghart 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 ''. - '
'.$announcement.'
'; + ''.$announcement.''; } else { return ''; } @@ -1627,7 +1631,7 @@ sub courseiddump { $tryserver))) { my ($key,$value)=split(/\=/,$_); if (($key) && ($value)) { - $returnhash{&unescape($key)}=&unescape($value); + $returnhash{&unescape($key)}=$value; } } } @@ -3076,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/=/,$_; @@ -3169,7 +3178,7 @@ sub auto_get_sections { sub auto_new_course { my ($cnum,$cdom,$inst_course_id,$owner) = @_; my $homeserver = &homeserver($cnum,$cdom); - my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner,':'.$cdom,$homeserver)); + my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); return $response; } @@ -3384,7 +3393,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'; @@ -3399,13 +3408,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'}) { @@ -3451,7 +3459,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; @@ -3487,7 +3495,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)) { @@ -3520,9 +3528,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; @@ -3575,6 +3583,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 { @@ -4838,6 +4882,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]) { @@ -4850,13 +4902,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) { @@ -4873,6 +4933,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/^\///;