--- loncom/lonnet/perl/lonnet.pm 2002/07/30 19:59:32 1.256 +++ loncom/lonnet/perl/lonnet.pm 2002/10/22 21:49:10 1.299 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.256 2002/07/30 19:59:32 albertel Exp $ +# $Id: lonnet.pm,v 1.299 2002/10/22 21:49:10 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -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 @@ -348,12 +350,36 @@ sub delenv { return 'ok'; } +# ------------------------------------------ Fight off request when overloaded + +sub overloaderror { + my ($r,$checkserver)=@_; + unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } + my $loadavg; + if ($checkserver eq $perlvar{'lonHostID'}) { + my $loadfile=Apache::File->new('/proc/loadavg'); + $loadavg=<$loadfile>; + $loadavg =~ s/\s.*//g; + $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; + } else { + $loadavg=&reply('load',$checkserver); + } + my $overload=$loadavg-100; + if ($overload>0) { + $r->err_headers_out->{'Retry-After'}=$overload; + $r->log_error('Overload of '.$overload.' on '.$checkserver); + return 413; + } + return ''; +} + # ------------------------------ Find server with least workload from spare.tab sub spareserver { + my $loadpercent = shift; my $tryserver; my $spareserver=''; - my $lowestserver=100; + my $lowestserver=$loadpercent; foreach $tryserver (keys %spareid) { my $answer=reply('load',$tryserver); if (($answer =~ /\d/) && ($answer<$lowestserver)) { @@ -567,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; @@ -608,6 +687,42 @@ sub userenvironment { return %returnhash; } +# -------------------------------------------------------------------- New chat + +sub chatsend { + my ($newentry,$anon)=@_; + my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + &reply('chatsend:'.$cdom.':'.$cnum.':'. + &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. + &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 { @@ -616,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); @@ -647,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") { @@ -682,6 +802,7 @@ sub repcopy { rename($transname,$filename); return OK; } + } } } @@ -712,11 +833,79 @@ sub ssi { sub tokenwrapper { my $uri=shift; - my $token=&reply('tmpput:'.&escape($uri),$perlvar{'lonHostID'}); - return $uri.(($uri=~/\?/)?'&':'?'). - 'token='.$token.'&server='.$perlvar{'lonHostID'}; + $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; + } else { + return '/adm/notfound.html'; + } } +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element, coursedoc=1 means this is for the course +# output: url of file in userspace + +sub userfileupload { + my ($formname,$coursedoc)=@_; + my $fname=$ENV{'form.'.$formname.'.filename'}; + $fname=~s/\\/\//g; + $fname=~s/^.*\/([^\/]+)$/$1/; + unless ($fname) { return 'error: no uploaded file'; } + chop($ENV{'form.'.$formname}); +# Create the directory if not present + my $docuname=''; + my $docudom=''; + my $docuhome=''; + if ($coursedoc) { + $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + } else { + $docuname=$ENV{'user.name'}; + $docudom=$ENV{'user.domain'}; + $docuhome=$ENV{'user.home'}; + } + return + &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); +} + +sub finishuserfileupload { + my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; + my $path=$docudom.'/'.$docuname.'/'; + my $filepath=$perlvar{'lonDocRoot'}; + my @parts=split(/\//,$filepath.'/userfiles/'.$path); + my $count; + for ($count=4;$count<=$#parts;$count++) { + $filepath.="/$parts[$count]"; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } +# Save the file + { + my $fh=Apache::File->new('>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + } +# Notify homeserver to grep it +# + + 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'; + } +} # ------------------------------------------------------------------------- Log @@ -749,7 +938,7 @@ sub flushcourselogs { my $entry=$_; $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; my %temphash=($entry => $accesshash{$entry}); - if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { + if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') { delete $accesshash{$entry}; } } @@ -794,7 +983,7 @@ sub countacc { my $url=&declutter(shift); unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; - my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; + my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; if (defined($accesshash{$key})) { $accesshash{$key}++; } else { @@ -914,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'}) @@ -929,97 +1118,195 @@ sub devalidate { } } +sub get_scalar { + my ($string,$end) = @_; + my $value; + if ($$string =~ s/^([^&]*?)($end)/$2/) { + $value = $1; + } elsif ($$string =~ s/^([^&]*?)&//) { + $value = $1; + } + return &unescape($value); +} + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + sub arrayref2str { my ($arrayref) = @_; - my $result='_ARRAY_REF__'; + my $result='__ARRAY_REF__'; foreach my $elem (@$arrayref) { - if (ref($elem) eq 'ARRAY') { - $result.=&escape(&arrayref2str($elem)).'&'; - } elsif (ref($elem) eq 'HASH') { - $result.=&escape(&hashref2str($elem)).'&'; - } elsif (ref($elem)) { - &logthis("Got a ref of ".(ref($elem))." skipping."); + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); } else { $result.=&escape($elem).'&'; } } $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; return $result; } sub hash2str { my (%hash) = @_; my $result=&hashref2str(\%hash); - $result=~s/^_HASH_REF__//; + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; return $result; } sub hashref2str { my ($hashref)=@_; - my $result='_HASH_REF__'; + my $result='__HASH_REF__'; foreach (keys(%$hashref)) { if (ref($_) eq 'ARRAY') { - $result.=&escape(&arrayref2str($_)).'='; + $result.=&arrayref2str($_).'='; } elsif (ref($_) eq 'HASH') { - $result.=&escape(&hashref2str($_)).'='; + $result.=&hashref2str($_).'='; } elsif (ref($_)) { - &logthis("Got a ref of ".(ref($_))." skipping."); + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); } else { - $result.=&escape($_).'='; + if ($_) {$result.=&escape($_).'=';} else { last; } } - if (ref($$hashref{$_}) eq 'ARRAY') { - $result.=&escape(&arrayref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_}) eq 'HASH') { - $result.=&escape(&hashref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_})) { - &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); } else { - $result.=&escape($$hashref{$_}).'&'; + $result.=&escape($hashref->{$_}).'&'; } } $result=~s/\&$//; + $result .= '__END_HASH_REF__'; return $result; } sub str2hash { + my ($string)=@_; + my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); + return %$hash; +} + +sub str2hashref { my ($string) = @_; - my %returnhash; - foreach (split(/\&/,$string)) { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - $returnhash{$name}=$value; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); } - return (%returnhash); + + $string =~ s/^__HASH_REF__//; + + while($string !~ /^__END_HASH_REF__/) { + #key + my $key=''; + if($string =~ /^__HASH_REF__/) { + ($key, $string)=&str2hashref($string); + if(defined($key->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($key, $string)=&str2arrayref($string); + if($key->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $string =~ s/^(.*?)=//; + $key=&unescape($1); + } + $string =~ s/^=//; + + #value + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $value=&get_scalar(\$string,'__END_HASH_REF__'); + } + $string =~ s/^&//; + + $hash{$key}=$value; + } + + $string =~ s/^__END_HASH_REF__//; + + return (\%hash, $string); } sub str2array { + my ($string)=@_; + my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); + return @$array; +} + +sub str2arrayref { my ($string) = @_; - my @returnarray; - foreach my $value (split(/\&/,$string)) { - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - push(@returnarray,$value); + my @array; + + if($string !~ /^__ARRAY_REF__/) { + if (! ($string eq '' || !defined($string))) { + $array[0]='Array reference error'; + } + return (\@array, $string); } - return (@returnarray); + + $string =~ s/^__ARRAY_REF__//; + + while($string !~ /^__END_ARRAY_REF__/) { + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } else { + $value=&get_scalar(\$string,'__END_ARRAY_REF__'); + } + $string =~ s/^&//; + + push(@array, $value); + } + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); } # -------------------------------------------------------------------Temp Store @@ -1266,7 +1553,7 @@ sub coursedescription { while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } - $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.last_cache'}=time; @@ -1394,6 +1681,9 @@ sub get { my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } my %returnhash=(); my $i=0; foreach (@$storearr) { @@ -1526,6 +1816,17 @@ sub allowed { return ''; } } + if ($ENV{'request.role'}=~ /li\.\//) { + # Library role, so allow browsing of resources in this domain. + return 'F'; + } + } + # Domain coordinator is trying to create a course + if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + # uri is the requested domain in this case. + # comparison to 'request.role.domain' shows if the user has selected + # a role of dc for the domain in question. + return 'F' if ($uri eq $ENV{'request.role.domain'}); } my $thisallowed=''; @@ -1773,14 +2074,15 @@ sub is_on_map { my @uriparts=split(/\//,$uri); my $filename=$uriparts[$#uriparts]; my $pathname=$uri; - $pathname=~s/\/$filename$//; + $pathname=~s|/\Q$filename\E$||; + #Trying to find the conditional for the file my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/); + /\&\Q$filename\E\:([\d\|]+)\&/); if ($match) { - return (1,$1); - } else { - return (0,0); - } + return (1,$1); + } else { + return (0,0); + } } # ----------------------------------------------------------------- Define Role @@ -1957,7 +2259,8 @@ sub modifyuserauth { my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. - $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, @@ -1988,7 +2291,8 @@ sub modifyuser { $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). - ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && ($umode) && ($upass)) { @@ -2069,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) { @@ -2113,13 +2456,10 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url)=@_; + my ($udom,$description,$url,$course_server,$nonstandard)=@_; $url=&declutter($url); my $cid=''; - unless (&allowed('ccc',$ENV{'user.domain'})) { - return 'refused'; - } - unless ($udom eq $ENV{'user.domain'}) { + unless (&allowed('ccc',$udom)) { return 'refused'; } # ------------------------------------------------------------------- Create ID @@ -2135,17 +2475,42 @@ sub createcourse { return 'error: unable to generate unique course-ID'; } } +# ------------------------------------------------ Check supplied server name + $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + if (! exists($libserv{$course_server})) { + return 'error:bad server name '.$course_server; + } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', - $ENV{'user.home'}); + $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } +# ----------------------------------------------------------------- Course made + my $topurl=$url; + unless ($nonstandard) { +# ------------------------------------------ For standard courses, make top url + my $mapurl=&clutter($url); + if ($mapurl eq '/res/') { $mapurl=''; } + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, ('description' => $description, - 'url' => $url)); + 'url' => $topurl)); return '/'.$udom.'/'.$uname; } @@ -2246,6 +2611,30 @@ sub dirlist { } } +# --------------------------------------------- GetFileTimestamp +# This function utilizes dirlist and returns the date stamp for +# when it was last modified. It will also return an error of -1 +# if an error occurs + +sub GetFileTimestamp { + my ($studentDomain,$studentName,$filename,$root)=@_; + $studentDomain=~s/\W//g; + $studentName=~s/\W//g; + my $subdir=$studentName.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + my $proname="$studentDomain/$subdir/$studentName"; + $proname .= '/'.$filename; + my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName, + $root); + my $fileStat = $dir[0]; + my @stats = split('&', $fileStat); + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + return $stats[9]; + } else { + return -1; + } +} + # -------------------------------------------------------- Value of a Condition sub directcondval { @@ -2298,6 +2687,14 @@ sub condval { return $result; } +# ---------------------------------------------------- Devalidate courseresdata + +sub devalidatecourseresdata { + my ($coursenum,$coursedomain)=@_; + my $hashid=$coursenum.':'.$coursedomain; + delete $courseresdatacache{$hashid.'.time'}; +} + # --------------------------------------------------- Course Resourcedata Query sub courseresdata { @@ -2319,17 +2716,17 @@ sub courseresdata { } } foreach my $item (@which) { - if ($courseresdatacache{$hashid}->{$item}) { + if (defined($courseresdatacache{$hashid}->{$item})) { return $courseresdatacache{$hashid}->{$item}; } } - return ''; + return undef; } # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname)=@_; + my ($varname,$symbparm,$udom,$uname,)=@_; unless ($varname) { return ''; } @@ -2470,7 +2867,7 @@ sub EXT { ($seclevelr,$seclevelm,$seclevel, $courselevelr,$courselevelm, $courselevel)); - if ($coursereply) { return $coursereply; } + if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms my %parmhash=(); @@ -2486,11 +2883,17 @@ sub EXT { # --------------------------------------------- last, look in resource metadata $spacequalifierrest=~s/\./\_/; - my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); - if ($metadata) { return $metadata; } - $metadata=&metadata($ENV{'request.filename'}, - 'parameter_'.$spacequalifierrest); - if ($metadata) { return $metadata; } + my $filename; + if (!$symbparm) { $symbparm=&symbread(); } + if ($symbparm) { + $filename=(split(/\_\_\_/,$symbparm))[2]; + } else { + $filename=$ENV{'request.filename'}; + } + my $metadata=&metadata($filename,$spacequalifierrest); + if (defined($metadata)) { return $metadata; } + $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + if (defined($metadata)) { return $metadata; } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { @@ -2498,11 +2901,11 @@ sub EXT { if ($id) { my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, $symbparm,$udom,$uname); - if ($partgeneral) { return $partgeneral; } + if (defined($partgeneral)) { return $partgeneral; } } else { my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, $symbparm,$udom,$uname); - if ($resourcegeneral) { return $resourcegeneral; } + if (defined($resourcegeneral)) { return $resourcegeneral; } } } @@ -2531,6 +2934,11 @@ sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); + # if it is a non metadata possible uri return quickly + if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) { + return ''; + } my $filename=$uri; $uri=~s/\.meta$//; # @@ -2538,7 +2946,7 @@ sub metadata { # Look at timestamp of caching # Everything is cached by the main uri, libraries are never directly cached # - unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { + unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) { # # Is this a recursive call for a library? # @@ -2561,7 +2969,7 @@ sub metadata { my $package=$token->[2]->{'package'}; my $keyroot=''; if ($prefix) { - $keyroot.='_'.$prefix; + $keyroot.=$prefix; } else { if (defined($token->[2]->{'part'})) { $keyroot.='_'.$token->[2]->{'part'}; @@ -2619,12 +3027,14 @@ sub metadata { # # Importing a library here # - if (defined($depthcount)) { $depthcount++; } else - { $depthcount=0; } if ($depthcount<20) { - foreach (split(/\,/,&metadata($uri,'keys', - $parser->get_text('/import'),$unikey, - $depthcount))) { + my $location=$parser->get_text('/import'); + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,$unikey, + $depthcount+1)))) { $metathesekeys{$_}=1; } } @@ -2650,12 +3060,42 @@ sub metadata { } } $metacache{$uri.':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); + $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached } return $metacache{$uri.':'.$what}; } +sub metadata_generate_part0 { + my ($metadata,$metacache,$uri) = @_; + my %allnames; + foreach my $metakey (sort keys %$metadata) { + if ($metakey=~/^parameter\_(.*)/) { + my $part=$$metacache{$uri.':'.$metakey.'.part'}; + my $name=$$metacache{$uri.':'.$metakey.'.name'}; + if (! exists($$metadata{'parameter_0_'.$name})) { + $allnames{$name}=$part; + } + } + } + foreach my $name (keys(%allnames)) { + $$metadata{"parameter_0_$name"}=1; + my $key="$uri:parameter_0_$name"; + $$metacache{"$key.part"}='0'; + $$metacache{"$key.name"}=$name; + $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'. + $allnames{$name}.'_'.$name. + '.type'}; + my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name. + '.display'}; + my $expr='\\[Part: '.$allnames{$name}.'\\]'; + $olddis=~s/$expr/\[Part: 0\]/; + $$metacache{"$key.display"}=$olddis; + } +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -2693,7 +3133,7 @@ sub symbverify { my $okay=0; if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $ids=$bighash{'ids_/res/'.$thisfn}; + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -2764,7 +3204,7 @@ sub symbread { if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { # ---------------------------------------------- Get ID(s) for current resource - my $ids=$bighash{'ids_/res/'.$thisfn}; + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -2864,20 +3304,31 @@ sub ireceipt { } sub receipt { - return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, - $ENV{'request.course.id'},&symbread()); + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb); } - + # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or a -1 sub getfile { - my $file=shift; + my $file=shift; + if ($file=~/^\/*uploaded\//) { # user file + 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; + } + } else { # normal file from res space &repcopy($file); if (! -e $file ) { return -1; }; my $fh=Apache::File->new($file); my $a=''; while (<$fh>) { $a .=$_; } - return $a + return $a; + } } sub filelocation { @@ -2887,6 +3338,8 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + $location=$file; } else { $file=~s/^$perlvar{'lonDocRoot'}//; $file=~s:^/*res::; @@ -2924,6 +3377,16 @@ sub declutter { return $thisfn; } +# ------------------------------------------------------------- Clutter up URLs + +sub clutter { + my $thisfn='/'.&declutter(shift); + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + $thisfn='/res'.$thisfn; + } + return $thisfn; +} + # -------------------------------------------------------- Escape Special Chars sub escape { @@ -3001,7 +3464,7 @@ BEGIN { while (my $configline=<$config>) { chomp($configline); - if (($configline) && ($configline ne $perlvar{'lonHostID'})) { + if ($configline) { $spareid{$configline}=1; } } @@ -3049,7 +3512,7 @@ BEGIN { %metacache=(); -$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; +$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; &logtouch(); @@ -3265,7 +3728,83 @@ modify user =item * -modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,$end,$start) : modify student +modifystudent + +modify a students enrollment and identification information. +The course id is resolved based on the current users environment. +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 and +lonnet::modify_student_enrollment + +Inputs: + +=over 4 + +=item B<$udom> Students loncapa domain + +=item B<$uname> Students loncapa login name + +=item B<$uid> Students id/student number + +=item B<$umode> Students authentication mode + +=item B<$upass> Students password + +=item B<$first> Students first name + +=item B<$middle> Students middle name + +=item B<$last> Students last name + +=item B<$gene> Students generation + +=item B<$usec> Students section in course + +=item B<$end> Unix time of the roles expiration + +=item B<$start> Unix time of the roles start date + +=item B<$forceid> If defined, allow $uid to be changed + +=item B<$desiredhome> server to use as home server for student + +=back + +=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 *