--- loncom/lonnet/perl/lonnet.pm 2002/10/01 19:09:27 1.289
+++ loncom/lonnet/perl/lonnet.pm 2002/11/12 22:23:37 1.300
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.289 2002/10/01 19:09:27 bowersj2 Exp $
+# $Id: lonnet.pm,v 1.300 2002/11/12 22:23:37 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -77,7 +77,7 @@ use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
use vars
-qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom
+qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab
%courselogs %accesshash $processmarker $dumpcount
%coursedombuf %coursehombuf %courseresdatacache %domaindescription);
@@ -86,6 +86,8 @@ use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::LCParser;
use Fcntl qw(:flock);
+use Apache::loncoursedata;
+
my $readit;
# --------------------------------------------------------------------- Logging
@@ -591,6 +593,59 @@ sub idput {
# ------------------------------------- Find the section of student in a course
+sub getsection {
+ my ($udom,$unam,$courseid)=@_;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+ my %Pending;
+ my %Expired;
+ #
+ # Each role can either have not started yet (pending), be active,
+ # or have expired.
+ #
+ # If there is an active role, we are done.
+ #
+ # If there is more than one role which has not started yet,
+ # choose the one which will start sooner
+ # If there is one role which has not started yet, return it.
+ #
+ # If there is more than one expired role, choose the one which ended last.
+ # If there is a role which has expired, return it.
+ #
+ foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
+ &homeserver($unam,$udom)))) {
+ my ($key,$value)=split(/\=/,$_);
+ $key=&unescape($key);
+ next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/);
+ my $section=$1;
+ if ($key eq $courseid.'_st') { $section=''; }
+ my ($dummy,$end,$start)=split(/\_/,&unescape($value));
+ my $now=time;
+ if (defined($end) && ($now > $end)) {
+ $Expired{$end}=$section;
+ next;
+ }
+ if (defined($start) && ($now < $start)) {
+ $Pending{$start}=$section;
+ next;
+ }
+ return $section;
+ }
+ #
+ # Presumedly there will be few matching roles from the above
+ # loop and the sorting time will be negligible.
+ if (scalar(keys(%Pending))) {
+ my ($time) = sort {$a <=> $b} keys(%Pending);
+ return $Pending{$time};
+ }
+ if (scalar(keys(%Expired))) {
+ my @sorted = sort {$a <=> $b} keys(%Expired);
+ my $time = pop(@sorted);
+ return $Expired{$time};
+ }
+ return '-1';
+}
+
sub usection {
my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;
@@ -644,6 +699,30 @@ sub chatsend {
&escape($newentry)),$chome);
}
+# ------------------------------------------ Find current version of a resource
+
+sub getversion {
+ my $fname=&clutter(shift);
+ unless ($fname=~/^\/res\//) { return -1; }
+ return ¤tversion(&filelocation('',$fname));
+}
+
+sub currentversion {
+ my $fname=shift;
+ my $author=$fname;
+ $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
+ my ($udom,$uname)=split(/\//,$author);
+ my $home=homeserver($uname,$udom);
+ if ($home eq 'no_host') {
+ return -1;
+ }
+ my $answer=reply("currentversion:$fname",$home);
+ if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
+ return -1;
+ }
+ return $answer;
+}
+
# ----------------------------- Subscribe to a resource, return URL if possible
sub subscribe {
@@ -652,7 +731,7 @@ sub subscribe {
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);
my $home=homeserver($uname,$udom);
- if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {
+ if ($home eq 'no_host') {
return 'not_found';
}
my $answer=reply("sub:$fname",$home);
@@ -683,6 +762,11 @@ sub repcopy {
} elsif ($remoteurl eq 'directory') {
return OK;
} else {
+ my $author=$filename;
+ $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
+ my ($udom,$uname)=split(/\//,$author);
+ my $home=homeserver($uname,$udom);
+ unless ($home eq $perlvar{'lonHostID'}) {
my @parts=split(/\//,$filename);
my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
if ($path ne "$perlvar{'lonDocRoot'}/res") {
@@ -718,6 +802,7 @@ sub repcopy {
rename($transname,$filename);
return OK;
}
+ }
}
}
@@ -808,13 +893,16 @@ sub finishuserfileupload {
}
# Notify homeserver to grep it
#
- if
-(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok')
- {
+
+ my $fetchresult=
+ &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
+ if ($fetchresult eq 'ok') {
#
# Return the URL to it
return '/uploaded/'.$path.$fname;
} else {
+ &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.
+ ' to host '.$docuhome.': '.$fetchresult);
return '/adm/notfound.html';
}
}
@@ -1015,7 +1103,7 @@ sub devalidate {
if ($cid) {
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
my $status=
- &del('nohist_calculatedsheet',
+ &del('nohist_calculatedsheets',
[$key.'studentcalc'],
$ENV{'course.'.$cid.'.domain'},
$ENV{'course.'.$cid.'.num'})
@@ -2285,20 +2373,59 @@ sub modifystudent {
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
$desiredhome);
unless ($reply eq 'ok') { return $reply; }
+ # This will cause &modify_student_enrollment to get the uid from the
+ # students environment
+ $uid = undef if (!$forceid);
+ $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,
+ $last,$gene,$usec,$end,$start);
+ return $reply;
+}
+
+sub modify_student_enrollment {
+ my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;
+ # Get the course id from the environment
+ my $cid='';
+ unless ($cid=$ENV{'request.course.id'}) {
+ return 'not_in_class';
+ }
+ # Make sure the user exists
my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such user';
}
-# -------------------------------------------------- Add student to course list
- $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
+ #
+ # Get student data if we were not given enough information
+ if (!defined($first) || $first eq '' ||
+ !defined($last) || $last eq '' ||
+ !defined($uid) || $uid eq '' ||
+ !defined($middle) || $middle eq '' ||
+ !defined($gene) || $gene eq '') {
+ # They did not supply us with enough data to enroll the student, so
+ # we need to pick up more information.
+ my %tmp = &get('environment',
+ ['firstname','middlename','lastname', 'generation','id']
+ ,$udom,$uname);
+
+ foreach (keys(%tmp)) {
+ &logthis("key $_ = ".$tmp{$_});
+ }
+ $first = $tmp{'firstname'} if (!defined($first) || $first eq '');
+ $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
+ $last = $tmp{'lastname'} if (!defined($last) || $last eq '');
+ $gene = $tmp{'generation'} if (!defined($gene) || $gene eq '');
+ $uid = $tmp{'id'} if (!defined($uid) || $uid eq '');
+ }
+ my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
+ $first,$middle);
+ my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
$ENV{'course.'.$cid.'.num'}.':classlist:'.
&escape($uname.':'.$udom).'='.
- &escape($end.':'.$start),
+ &escape(join(':',$end,$start,$uid,$usec,$fullname)),
$ENV{'course.'.$cid.'.home'});
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return 'error: '.$reply;
}
-# ---------------------------------------------------- Add student role to user
+ # Add student role to user
my $uurl='/'.$cid;
$uurl=~s/\_/\//g;
if ($usec) {
@@ -2593,7 +2720,7 @@ sub courseresdata {
return $courseresdatacache{$hashid}->{$item};
}
}
- return '';
+ return undef;
}
# --------------------------------------------------------- Value of a Variable
@@ -2808,8 +2935,8 @@ sub metadata {
$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly
- if (($uri eq '') || ($uri =~ m|^/*adm/|) || ($uri =~ m|/$|) ||
- ($uri =~ m|/.meta$|)) {
+ if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) {
return '';
}
my $filename=$uri;
@@ -3321,6 +3448,7 @@ BEGIN {
$hostname{$id}=$name;
$hostdom{$id}=$domain;
$hostip{$id}=$ip;
+ $iphost{$ip}=$id;
if ($domdescr) { $domaindescription{$domain}=$domdescr; }
if ($role eq 'library') { $libserv{$id}=$name; }
} else {
@@ -3608,7 +3736,8 @@ The course id is resolved based on the c
This means the envoking user must be a course coordinator or otherwise
associated with a course.
-This call is essentially a wrapper for lonnet::modifyuser
+This call is essentially a wrapper for lonnet::modifyuser and
+lonnet::modify_student_enrollment
Inputs:
@@ -3646,6 +3775,40 @@ Inputs:
=item *
+modify_student_enrollment
+
+Change a students enrollment status in a class. The environment variable
+'role.request.course' must be defined for this function to proceed.
+
+Inputs:
+
+=over 4
+
+=item $udom, students domain
+
+=item $uname, students name
+
+=item $uid, students user id
+
+=item $first, students first name
+
+=item $middle
+
+=item $last
+
+=item $gene
+
+=item $usec
+
+=item $end
+
+=item $start
+
+=back
+
+
+=item *
+
assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
custom role; give a custom role to a user for the level given by URL. Specify
name and domain of role author, and role name