|
version 1.263, 2002/08/08 13:42:01
|
version 1.316, 2003/01/10 20:55:44
|
|
Line 77 use Apache::File;
|
Line 77 use Apache::File;
|
| use LWP::UserAgent(); |
use LWP::UserAgent(); |
| use HTTP::Headers; |
use HTTP::Headers; |
| use vars |
use vars |
| qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
| %libserv %pr %prp %metacache %packagetab |
%libserv %pr %prp %metacache %packagetab %titlecache |
| %courselogs %accesshash $processmarker $dumpcount |
%courselogs %accesshash $processmarker $dumpcount |
| %coursedombuf %coursehombuf %courseresdatacache %domaindescription); |
%coursedombuf %coursehombuf %courseresdatacache |
| |
%domaindescription); |
| use IO::Socket; |
use IO::Socket; |
| use GDBM_File; |
use GDBM_File; |
| use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
| use HTML::LCParser; |
use HTML::LCParser; |
| use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
| |
use Apache::loncoursedata; |
| |
|
| my $readit; |
my $readit; |
| |
|
| # --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
Line 140 sub reply {
|
Line 143 sub reply {
|
| unless (defined($hostname{$server})) { return 'no_such_host'; } |
unless (defined($hostname{$server})) { return 'no_such_host'; } |
| my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| #sleep 5; |
#sleep 5; |
| #$answer=subreply($cmd,$server); |
#$answer=subreply($cmd,$server); |
| #if ($answer eq 'con_lost') { |
#if ($answer eq 'con_lost') { |
| # &logthis("Second attempt con_lost on $server"); |
# &logthis("Second attempt con_lost on $server"); |
| # my $peerfile="$perlvar{'lonSockDir'}/$server"; |
# my $peerfile="$perlvar{'lonSockDir'}/$server"; |
| # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
|
Line 213 sub critical {
|
Line 216 sub critical {
|
| $middlename=substr($middlename,0,16); |
$middlename=substr($middlename,0,16); |
| $middlename=~s/\W//g; |
$middlename=~s/\W//g; |
| my $dfilename= |
my $dfilename= |
| "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; |
"$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; |
| |
$dumpcount++; |
| { |
{ |
| my $dfh; |
my $dfh; |
| if ($dfh=Apache::File->new(">$dfilename")) { |
if ($dfh=Apache::File->new(">$dfilename")) { |
|
Line 348 sub delenv {
|
Line 352 sub delenv {
|
| return 'ok'; |
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 |
# ------------------------------ Find server with least workload from spare.tab |
| |
|
| sub spareserver { |
sub spareserver { |
| |
my $loadpercent = shift; |
| my $tryserver; |
my $tryserver; |
| my $spareserver=''; |
my $spareserver=''; |
| my $lowestserver=100; |
my $lowestserver=$loadpercent; |
| foreach $tryserver (keys %spareid) { |
foreach $tryserver (keys %spareid) { |
| my $answer=reply('load',$tryserver); |
my $answer=reply('load',$tryserver); |
| if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
|
Line 567 sub idput {
|
Line 595 sub idput {
|
| |
|
| # ------------------------------------- Find the section of student in a course |
# ------------------------------------- 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 { |
sub usection { |
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
|
Line 620 sub chatsend {
|
Line 701 sub chatsend {
|
| &escape($newentry)),$chome); |
&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 |
# ----------------------------- Subscribe to a resource, return URL if possible |
| |
|
| sub subscribe { |
sub subscribe { |
| my $fname=shift; |
my $fname=shift; |
| |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
| my $author=$fname; |
my $author=$fname; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
| my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
| my $home=homeserver($uname,$udom); |
my $home=homeserver($uname,$udom); |
| if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { |
if ($home eq 'no_host') { |
| return 'not_found'; |
return 'not_found'; |
| } |
} |
| my $answer=reply("sub:$fname",$home); |
my $answer=reply("sub:$fname",$home); |
|
Line 659 sub repcopy {
|
Line 765 sub repcopy {
|
| } elsif ($remoteurl eq 'directory') { |
} elsif ($remoteurl eq 'directory') { |
| return OK; |
return OK; |
| } else { |
} 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 @parts=split(/\//,$filename); |
| my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; |
my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; |
| if ($path ne "$perlvar{'lonDocRoot'}/res") { |
if ($path ne "$perlvar{'lonDocRoot'}/res") { |
|
Line 694 sub repcopy {
|
Line 805 sub repcopy {
|
| rename($transname,$filename); |
rename($transname,$filename); |
| return OK; |
return OK; |
| } |
} |
| |
} |
| } |
} |
| } |
} |
| |
|
|
Line 731 sub tokenwrapper {
|
Line 843 sub tokenwrapper {
|
| if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { |
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { |
| &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); |
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); |
| return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. |
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. |
| (($uri=~/\?/)?'&':'?').'token='.$token; |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| |
'&tokenissued='.$perlvar{'lonHostID'}; |
| } else { |
} else { |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
|
Line 744 sub tokenwrapper {
|
Line 857 sub tokenwrapper {
|
| sub userfileupload { |
sub userfileupload { |
| my ($formname,$coursedoc)=@_; |
my ($formname,$coursedoc)=@_; |
| my $fname=$ENV{'form.'.$formname.'.filename'}; |
my $fname=$ENV{'form.'.$formname.'.filename'}; |
| |
# Replace Windows backslashes by forward slashes |
| $fname=~s/\\/\//g; |
$fname=~s/\\/\//g; |
| |
# Get rid of everything but the actual filename |
| $fname=~s/^.*\/([^\/]+)$/$1/; |
$fname=~s/^.*\/([^\/]+)$/$1/; |
| |
# Replace spaces by underscores |
| |
$fname=~s/\s+/\_/g; |
| |
# Replace all other weird characters by nothing |
| |
$fname=~s/[^\w\.\-\+]//g; |
| |
# See if there is anything left |
| unless ($fname) { return 'error: no uploaded file'; } |
unless ($fname) { return 'error: no uploaded file'; } |
| chop($ENV{'form.'.$formname}); |
chop($ENV{'form.'.$formname}); |
| # Create the directory if not present |
# Create the directory if not present |
|
Line 761 sub userfileupload {
|
Line 881 sub userfileupload {
|
| $docudom=$ENV{'user.domain'}; |
$docudom=$ENV{'user.domain'}; |
| $docuhome=$ENV{'user.home'}; |
$docuhome=$ENV{'user.home'}; |
| } |
} |
| |
return |
| |
&finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); |
| |
} |
| |
|
| |
sub finishuserfileupload { |
| |
my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| my @parts=split(/\//,$filepath.'/userfiles/'.$path); |
my @parts=split(/\//,$filepath.'/userfiles/'.$path); |
|
Line 778 sub userfileupload {
|
Line 904 sub userfileupload {
|
| } |
} |
| # Notify homeserver to grep it |
# 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 the URL to it |
| return '/uploaded/'.$path.$fname; |
return '/uploaded/'.$path.$fname; |
| } else { |
} else { |
| |
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname. |
| |
' to host '.$docuhome.': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
|
Line 820 sub flushcourselogs {
|
Line 949 sub flushcourselogs {
|
| my $entry=$_; |
my $entry=$_; |
| $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; |
$entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; |
| my %temphash=($entry => $accesshash{$entry}); |
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}; |
delete $accesshash{$entry}; |
| } |
} |
| } |
} |
|
Line 865 sub countacc {
|
Line 994 sub countacc {
|
| my $url=&declutter(shift); |
my $url=&declutter(shift); |
| unless ($ENV{'request.course.id'}) { return ''; } |
unless ($ENV{'request.course.id'}) { return ''; } |
| $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; |
$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; |
| my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; |
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; |
| if (defined($accesshash{$key})) { |
if (defined($accesshash{$key})) { |
| $accesshash{$key}++; |
$accesshash{$key}++; |
| } else { |
} else { |
|
Line 985 sub devalidate {
|
Line 1114 sub devalidate {
|
| if ($cid) { |
if ($cid) { |
| my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; |
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; |
| my $status= |
my $status= |
| &del('nohist_calculatedsheet', |
&del('nohist_calculatedsheets', |
| [$key.'studentcalc'], |
[$key.'studentcalc'], |
| $ENV{'course.'.$cid.'.domain'}, |
$ENV{'course.'.$cid.'.domain'}, |
| $ENV{'course.'.$cid.'.num'}) |
$ENV{'course.'.$cid.'.num'}) |
|
Line 1000 sub devalidate {
|
Line 1129 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 { |
sub arrayref2str { |
| my ($arrayref) = @_; |
my ($arrayref) = @_; |
| my $result='_ARRAY_REF__'; |
my $result='__ARRAY_REF__'; |
| foreach my $elem (@$arrayref) { |
foreach my $elem (@$arrayref) { |
| if (ref($elem) eq 'ARRAY') { |
if(ref($elem) eq 'ARRAY') { |
| $result.=&escape(&arrayref2str($elem)).'&'; |
$result.=&arrayref2str($elem).'&'; |
| } elsif (ref($elem) eq 'HASH') { |
} elsif(ref($elem) eq 'HASH') { |
| $result.=&escape(&hashref2str($elem)).'&'; |
$result.=&hashref2str($elem).'&'; |
| } elsif (ref($elem)) { |
} elsif(ref($elem)) { |
| &logthis("Got a ref of ".(ref($elem))." skipping."); |
#print("Got a ref of ".(ref($elem))." skipping."); |
| } else { |
} else { |
| $result.=&escape($elem).'&'; |
$result.=&escape($elem).'&'; |
| } |
} |
| } |
} |
| $result=~s/\&$//; |
$result=~s/\&$//; |
| |
$result .= '__END_ARRAY_REF__'; |
| return $result; |
return $result; |
| } |
} |
| |
|
| sub hash2str { |
sub hash2str { |
| my (%hash) = @_; |
my (%hash) = @_; |
| my $result=&hashref2str(\%hash); |
my $result=&hashref2str(\%hash); |
| $result=~s/^_HASH_REF__//; |
$result=~s/^__HASH_REF__//; |
| |
$result=~s/__END_HASH_REF__$//; |
| return $result; |
return $result; |
| } |
} |
| |
|
| sub hashref2str { |
sub hashref2str { |
| my ($hashref)=@_; |
my ($hashref)=@_; |
| my $result='_HASH_REF__'; |
my $result='__HASH_REF__'; |
| foreach (keys(%$hashref)) { |
foreach (keys(%$hashref)) { |
| if (ref($_) eq 'ARRAY') { |
if (ref($_) eq 'ARRAY') { |
| $result.=&escape(&arrayref2str($_)).'='; |
$result.=&arrayref2str($_).'='; |
| } elsif (ref($_) eq 'HASH') { |
} elsif (ref($_) eq 'HASH') { |
| $result.=&escape(&hashref2str($_)).'='; |
$result.=&hashref2str($_).'='; |
| } elsif (ref($_)) { |
} elsif (ref($_)) { |
| &logthis("Got a ref of ".(ref($_))." skipping."); |
$result.='='; |
| |
#print("Got a ref of ".(ref($_))." skipping."); |
| } else { |
} else { |
| $result.=&escape($_).'='; |
if ($_) {$result.=&escape($_).'=';} else { last; } |
| } |
} |
| |
|
| if (ref($$hashref{$_}) eq 'ARRAY') { |
if(ref($hashref->{$_}) eq 'ARRAY') { |
| $result.=&escape(&arrayref2str($$hashref{$_})).'&'; |
$result.=&arrayref2str($hashref->{$_}).'&'; |
| } elsif (ref($$hashref{$_}) eq 'HASH') { |
} elsif(ref($hashref->{$_}) eq 'HASH') { |
| $result.=&escape(&hashref2str($$hashref{$_})).'&'; |
$result.=&hashref2str($hashref->{$_}).'&'; |
| } elsif (ref($$hashref{$_})) { |
} elsif(ref($hashref->{$_})) { |
| &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); |
$result.='&'; |
| |
#print("Got a ref of ".(ref($hashref->{$_}))." skipping."); |
| } else { |
} else { |
| $result.=&escape($$hashref{$_}).'&'; |
$result.=&escape($hashref->{$_}).'&'; |
| } |
} |
| } |
} |
| $result=~s/\&$//; |
$result=~s/\&$//; |
| |
$result .= '__END_HASH_REF__'; |
| return $result; |
return $result; |
| } |
} |
| |
|
| sub str2hash { |
sub str2hash { |
| |
my ($string)=@_; |
| |
my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); |
| |
return %$hash; |
| |
} |
| |
|
| |
sub str2hashref { |
| my ($string) = @_; |
my ($string) = @_; |
| my %returnhash; |
|
| foreach (split(/\&/,$string)) { |
my %hash; |
| my ($name,$value)=split(/\=/,$_); |
|
| $name=&unescape($name); |
if($string !~ /^__HASH_REF__/) { |
| $value=&unescape($value); |
if (! ($string eq '' || !defined($string))) { |
| if ($value =~ /^_HASH_REF__/) { |
$hash{'error'}='Not hash reference'; |
| $value =~ s/^_HASH_REF__//; |
} |
| my %hash=&str2hash($value); |
return (\%hash, $string); |
| $value=\%hash; |
} |
| } elsif ($value =~ /^_ARRAY_REF__/) { |
|
| $value =~ s/^_ARRAY_REF__//; |
$string =~ s/^__HASH_REF__//; |
| my @array=&str2array($value); |
|
| $value=\@array; |
while($string !~ /^__END_HASH_REF__/) { |
| } |
#key |
| $returnhash{$name}=$value; |
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; |
| } |
} |
| return (%returnhash); |
|
| |
$string =~ s/^__END_HASH_REF__//; |
| |
|
| |
return (\%hash, $string); |
| } |
} |
| |
|
| sub str2array { |
sub str2array { |
| |
my ($string)=@_; |
| |
my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); |
| |
return @$array; |
| |
} |
| |
|
| |
sub str2arrayref { |
| my ($string) = @_; |
my ($string) = @_; |
| my @returnarray; |
my @array; |
| foreach my $value (split(/\&/,$string)) { |
|
| $value=&unescape($value); |
if($string !~ /^__ARRAY_REF__/) { |
| if ($value =~ /^_HASH_REF__/) { |
if (! ($string eq '' || !defined($string))) { |
| $value =~ s/^_HASH_REF__//; |
$array[0]='Array reference error'; |
| my %hash=&str2hash($value); |
} |
| $value=\%hash; |
return (\@array, $string); |
| } elsif ($value =~ /^_ARRAY_REF__/) { |
|
| $value =~ s/^_ARRAY_REF__//; |
|
| my @array=&str2array($value); |
|
| $value=\@array; |
|
| } |
|
| push(@returnarray,$value); |
|
| } |
} |
| 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 |
# -------------------------------------------------------------------Temp Store |
|
Line 1326 sub coursedescription {
|
Line 1553 sub coursedescription {
|
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
| my ($cdomain,$cnum)=split(/\//,$courseid); |
my ($cdomain,$cnum)=split(/\//,$courseid); |
| my $chome=&homeserver($cnum,$cdomain); |
my $chome=&homeserver($cnum,$cdomain); |
| |
my $normalid=$cdomain.'_'.$cnum; |
| |
# need to always cache even if we get errors otherwise we keep |
| |
# trying and trying and trying to get the course description. |
| |
my %envhash=(); |
| |
my %returnhash=(); |
| |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
| if ($chome ne 'no_host') { |
if ($chome ne 'no_host') { |
| my %returnhash=&dump('environment',$cdomain,$cnum); |
%returnhash=&dump('environment',$cdomain,$cnum); |
| if (!exists($returnhash{'con_lost'})) { |
if (!exists($returnhash{'con_lost'})) { |
| my $normalid=$cdomain.'_'.$cnum; |
|
| my %envhash=(); |
|
| $returnhash{'home'}= $chome; |
$returnhash{'home'}= $chome; |
| $returnhash{'domain'} = $cdomain; |
$returnhash{'domain'} = $cdomain; |
| $returnhash{'num'} = $cnum; |
$returnhash{'num'} = $cnum; |
| while (my ($name,$value) = each %returnhash) { |
while (my ($name,$value) = each %returnhash) { |
| $envhash{'course.'.$normalid.'.'.$name}=$value; |
$envhash{'course.'.$normalid.'.'.$name}=$value; |
| } |
} |
| $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); |
$returnhash{'url'}=&clutter($returnhash{'url'}); |
| $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
| $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
| $envhash{'course.'.$normalid.'.last_cache'}=time; |
|
| $envhash{'course.'.$normalid.'.home'}=$chome; |
$envhash{'course.'.$normalid.'.home'}=$chome; |
| $envhash{'course.'.$normalid.'.domain'}=$cdomain; |
$envhash{'course.'.$normalid.'.domain'}=$cdomain; |
| $envhash{'course.'.$normalid.'.num'}=$cnum; |
$envhash{'course.'.$normalid.'.num'}=$cnum; |
| &appenv(%envhash); |
|
| return %returnhash; |
|
| } |
} |
| } |
} |
| return (); |
&appenv(%envhash); |
| |
return %returnhash; |
| } |
} |
| |
|
| # -------------------------------------------------------- Get user privileges |
# -------------------------------------------------------- Get user privileges |
|
Line 1465 sub get {
|
Line 1694 sub get {
|
| |
|
| my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); |
my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| |
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
| |
return @pairs; |
| |
} |
| my %returnhash=(); |
my %returnhash=(); |
| my $i=0; |
my $i=0; |
| foreach (@$storearr) { |
foreach (@$storearr) { |
|
Line 1583 sub allowed {
|
Line 1815 sub allowed {
|
| |
|
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
| my $copyright=&metadata($uri,'copyright'); |
my $copyright=&metadata($uri,'copyright'); |
| if ($copyright eq 'public') { return 'F'; } |
if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { |
| |
return 'F'; |
| |
} |
| if ($copyright eq 'priv') { |
if ($copyright eq 'priv') { |
| $uri=~/([^\/]+)\/([^\/]+)\//; |
$uri=~/([^\/]+)\/([^\/]+)\//; |
| unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { |
unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { |
|
Line 1602 sub allowed {
|
Line 1836 sub allowed {
|
| return 'F'; |
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=''; |
my $thisallowed=''; |
| my $statecond=0; |
my $statecond=0; |
|
Line 1630 sub allowed {
|
Line 1871 sub allowed {
|
| $thisallowed.=$1; |
$thisallowed.=$1; |
| } |
} |
| |
|
| |
# URI is an uploaded document for this course |
| |
|
| |
if (($priv eq 'bre') && |
| |
($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) { |
| |
return 'F'; |
| |
} |
| # Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
| |
|
| if ($thisallowed=~/F/) { |
if ($thisallowed=~/F/) { |
|
Line 1848 sub is_on_map {
|
Line 2095 sub is_on_map {
|
| my @uriparts=split(/\//,$uri); |
my @uriparts=split(/\//,$uri); |
| my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
| my $pathname=$uri; |
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}=~ |
my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
| /\&$filename\:([\d\|]+)\&/); |
/\&\Q$filename\E\:([\d\|]+)\&/); |
| if ($match) { |
if ($match) { |
| return (1,$1); |
return (1,$1); |
| } else { |
} else { |
| return (0,0); |
return (0,0); |
| } |
} |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Define Role |
# ----------------------------------------------------------------- Define Role |
|
Line 2032 sub modifyuserauth {
|
Line 2280 sub modifyuserauth {
|
| my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
| unless (&allowed('mau',$udom)) { return 'refused'; } |
unless (&allowed('mau',$udom)) { return 'refused'; } |
| &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. |
&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.':'. |
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. |
| &escape($upass),$uhome); |
&escape($upass),$uhome); |
| &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, |
|
Line 2063 sub modifyuser {
|
Line 2312 sub modifyuser {
|
| $last.', '.$gene.'(forceid: '.$forceid.')'. |
$last.', '.$gene.'(forceid: '.$forceid.')'. |
| (defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
| ' desiredhome not specified'). |
' 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'); |
my $uhome=&homeserver($uname,$udom,'true'); |
| # ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
| if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
|
Line 2113 sub modifyuser {
|
Line 2363 sub modifyuser {
|
| } |
} |
| } |
} |
| # -------------------------------------------------------------- Add names, etc |
# -------------------------------------------------------------- Add names, etc |
| my %names=&get('environment', |
my @tmp=&get('environment', |
| ['firstname','middlename','lastname','generation'], |
['firstname','middlename','lastname','generation'], |
| $udom,$uname); |
$udom,$uname); |
| if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } |
my %names; |
| |
if ($tmp[0] =~ m/^error:.*/) { |
| |
%names=(); |
| |
} else { |
| |
%names = @tmp; |
| |
} |
| if ($first) { $names{'firstname'} = $first; } |
if ($first) { $names{'firstname'} = $first; } |
| if ($middle) { $names{'middlename'} = $middle; } |
if ($middle) { $names{'middlename'} = $middle; } |
| if ($last) { $names{'lastname'} = $last; } |
if ($last) { $names{'lastname'} = $last; } |
|
Line 2144 sub modifystudent {
|
Line 2399 sub modifystudent {
|
| ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
| $desiredhome); |
$desiredhome); |
| unless ($reply eq 'ok') { return $reply; } |
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); |
my $uhome=&homeserver($uname,$udom); |
| if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| return 'error: no such user'; |
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:'. |
$ENV{'course.'.$cid.'.num'}.':classlist:'. |
| &escape($uname.':'.$udom).'='. |
&escape($uname.':'.$udom).'='. |
| &escape($end.':'.$start), |
&escape(join(':',$end,$start,$uid,$usec,$fullname)), |
| $ENV{'course.'.$cid.'.home'}); |
$ENV{'course.'.$cid.'.home'}); |
| unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
| return 'error: '.$reply; |
return 'error: '.$reply; |
| } |
} |
| # ---------------------------------------------------- Add student role to user |
# Add student role to user |
| my $uurl='/'.$cid; |
my $uurl='/'.$cid; |
| $uurl=~s/\_/\//g; |
$uurl=~s/\_/\//g; |
| if ($usec) { |
if ($usec) { |
|
Line 2188 sub writecoursepref {
|
Line 2482 sub writecoursepref {
|
| # ---------------------------------------------------------- Make/modify course |
# ---------------------------------------------------------- Make/modify course |
| |
|
| sub createcourse { |
sub createcourse { |
| my ($udom,$description,$url)=@_; |
my ($udom,$description,$url,$course_server,$nonstandard)=@_; |
| $url=&declutter($url); |
$url=&declutter($url); |
| my $cid=''; |
my $cid=''; |
| unless (&allowed('ccc',$ENV{'user.domain'})) { |
unless (&allowed('ccc',$udom)) { |
| return 'refused'; |
|
| } |
|
| unless ($udom eq $ENV{'user.domain'}) { |
|
| return 'refused'; |
return 'refused'; |
| } |
} |
| # ------------------------------------------------------------------- Create ID |
# ------------------------------------------------------------------- Create ID |
|
Line 2210 sub createcourse {
|
Line 2501 sub createcourse {
|
| return 'error: unable to generate unique course-ID'; |
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 |
# ------------------------------------------------------------- Make the course |
| my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
| $ENV{'user.home'}); |
$course_server); |
| unless ($reply eq 'ok') { return 'error: '.$reply; } |
unless ($reply eq 'ok') { return 'error: '.$reply; } |
| $uhome=&homeserver($uname,$udom,'true'); |
$uhome=&homeserver($uname,$udom,'true'); |
| if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| return 'error: no such course'; |
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); |
| |
<map> |
| |
<resource id="1" type="start"></resource> |
| |
<resource id="2" src="$mapurl"></resource> |
| |
<resource id="3" type="finish"></resource> |
| |
<link index="1" from="1" to="2"></link> |
| |
<link index="2" from="2" to="3"></link> |
| |
</map> |
| |
ENDINITMAP |
| |
$topurl=&declutter( |
| |
&finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') |
| |
); |
| |
} |
| |
# ----------------------------------------------------------- Write preferences |
| &writecoursepref($udom.'_'.$uname, |
&writecoursepref($udom.'_'.$uname, |
| ('description' => $description, |
('description' => $description, |
| 'url' => $url)); |
'url' => $topurl)); |
| return '/'.$udom.'/'.$uname; |
return '/'.$udom.'/'.$uname; |
| } |
} |
| |
|
|
Line 2321 sub dirlist {
|
Line 2637 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 |
# -------------------------------------------------------- Value of a Condition |
| |
|
| sub directcondval { |
sub directcondval { |
|
Line 2373 sub condval {
|
Line 2713 sub condval {
|
| return $result; |
return $result; |
| } |
} |
| |
|
| |
# ---------------------------------------------------- Devalidate courseresdata |
| |
|
| |
sub devalidatecourseresdata { |
| |
my ($coursenum,$coursedomain)=@_; |
| |
my $hashid=$coursenum.':'.$coursedomain; |
| |
delete $courseresdatacache{$hashid.'.time'}; |
| |
} |
| |
|
| # --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
| |
|
| sub courseresdata { |
sub courseresdata { |
|
Line 2391 sub courseresdata {
|
Line 2739 sub courseresdata {
|
| if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
| $courseresdatacache{$hashid.'.time'}=time; |
$courseresdatacache{$hashid.'.time'}=time; |
| $courseresdatacache{$hashid}=\%dumpreply; |
$courseresdatacache{$hashid}=\%dumpreply; |
| |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| |
return $tmp; |
| } |
} |
| } |
} |
| foreach my $item (@which) { |
foreach my $item (@which) { |
| if ($courseresdatacache{$hashid}->{$item}) { |
if (defined($courseresdatacache{$hashid}->{$item})) { |
| return $courseresdatacache{$hashid}->{$item}; |
return $courseresdatacache{$hashid}->{$item}; |
| } |
} |
| } |
} |
| return ''; |
return undef; |
| } |
} |
| |
|
| # --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
| |
|
| sub EXT { |
sub EXT { |
| my ($varname,$symbparm,$udom,$uname)=@_; |
my ($varname,$symbparm,$udom,$uname,)=@_; |
| |
|
| unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
| |
|
|
Line 2517 sub EXT {
|
Line 2867 sub EXT {
|
| my $courselevelm=$courseid.'.'.$mapparm; |
my $courselevelm=$courseid.'.'.$mapparm; |
| |
|
| # ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
| my %resourcedata=&get('resourcedata', |
#most student don't have any data set, check if there is some data |
| [$courselevelr,$courselevelm,$courselevel], |
#every thirty minutes |
| $udom,$uname); |
if (! |
| if (($resourcedata{$courselevelr}!~/^error\:/) && |
(exists($ENV{'cache.studentresdata'}) |
| ($resourcedata{$courselevelr}!~/^con_lost/)) { |
&& (($ENV{'cache.studentresdata'}+1800) > time))) { |
| |
my %resourcedata=&get('resourcedata', |
| if ($resourcedata{$courselevelr}) { |
[$courselevelr,$courselevelm,$courselevel], |
| return $resourcedata{$courselevelr}; } |
$udom,$uname); |
| if ($resourcedata{$courselevelm}) { |
my ($tmp)=keys(%resourcedata); |
| return $resourcedata{$courselevelm}; } |
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
| if ($resourcedata{$courselevel}) { |
if ($resourcedata{$courselevelr}) { |
| return $resourcedata{$courselevel}; } |
return $resourcedata{$courselevelr}; } |
| } else { |
if ($resourcedata{$courselevelm}) { |
| if ($resourcedata{$courselevelr}!~/No such file/) { |
return $resourcedata{$courselevelm}; } |
| &logthis("<font color=blue>WARNING:". |
if ($resourcedata{$courselevel}) { |
| " Trying to get resource data for ". |
return $resourcedata{$courselevel}; } |
| $uname." at ".$udom.": ". |
} else { |
| $resourcedata{$courselevelr}."</font>"); |
if ($tmp!~/No such file/) { |
| |
&logthis("<font color=blue>WARNING:". |
| |
" Trying to get resource data for ". |
| |
$uname." at ".$udom.": ". |
| |
$tmp."</font>"); |
| |
} elsif ($tmp=~/error:No such file/) { |
| |
$ENV{'cache.studentresdata'}=time; |
| |
&appenv(('cache.studentresdata'=> |
| |
$ENV{'cache.studentresdata'})); |
| |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| |
return $tmp; |
| |
} |
| } |
} |
| } |
} |
| |
|
|
Line 2545 sub EXT {
|
Line 2906 sub EXT {
|
| ($seclevelr,$seclevelm,$seclevel, |
($seclevelr,$seclevelm,$seclevel, |
| $courselevelr,$courselevelm, |
$courselevelr,$courselevelm, |
| $courselevel)); |
$courselevel)); |
| if ($coursereply) { return $coursereply; } |
if (defined($coursereply)) { return $coursereply; } |
| |
|
| # ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
| my %parmhash=(); |
my %parmhash=(); |
|
Line 2561 sub EXT {
|
Line 2922 sub EXT {
|
| # --------------------------------------------- last, look in resource metadata |
# --------------------------------------------- last, look in resource metadata |
| |
|
| $spacequalifierrest=~s/\./\_/; |
$spacequalifierrest=~s/\./\_/; |
| my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); |
my $filename; |
| if ($metadata) { return $metadata; } |
if (!$symbparm) { $symbparm=&symbread(); } |
| $metadata=&metadata($ENV{'request.filename'}, |
if ($symbparm) { |
| 'parameter_'.$spacequalifierrest); |
$filename=(split(/\_\_\_/,$symbparm))[2]; |
| if ($metadata) { return $metadata; } |
} 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 |
# ------------------------------------------------------------------ Cascade up |
| unless ($space eq '0') { |
unless ($space eq '0') { |
|
Line 2573 sub EXT {
|
Line 2940 sub EXT {
|
| if ($id) { |
if ($id) { |
| my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
| $symbparm,$udom,$uname); |
$symbparm,$udom,$uname); |
| if ($partgeneral) { return $partgeneral; } |
if (defined($partgeneral)) { return $partgeneral; } |
| } else { |
} else { |
| my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, |
my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, |
| $symbparm,$udom,$uname); |
$symbparm,$udom,$uname); |
| if ($resourcegeneral) { return $resourcegeneral; } |
if (defined($resourcegeneral)) { return $resourcegeneral; } |
| } |
} |
| } |
} |
| |
|
|
Line 2606 sub metadata {
|
Line 2973 sub metadata {
|
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
| |
|
| $uri=&declutter($uri); |
$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; |
my $filename=$uri; |
| $uri=~s/\.meta$//; |
$uri=~s/\.meta$//; |
| # |
# |
|
Line 2613 sub metadata {
|
Line 2985 sub metadata {
|
| # Look at timestamp of caching |
# Look at timestamp of caching |
| # Everything is cached by the main uri, libraries are never directly cached |
# 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? |
# Is this a recursive call for a library? |
| # |
# |
|
Line 2636 sub metadata {
|
Line 3008 sub metadata {
|
| my $package=$token->[2]->{'package'}; |
my $package=$token->[2]->{'package'}; |
| my $keyroot=''; |
my $keyroot=''; |
| if ($prefix) { |
if ($prefix) { |
| $keyroot.='_'.$prefix; |
$keyroot.=$prefix; |
| } else { |
} else { |
| if (defined($token->[2]->{'part'})) { |
if (defined($token->[2]->{'part'})) { |
| $keyroot.='_'.$token->[2]->{'part'}; |
$keyroot.='_'.$token->[2]->{'part'}; |
|
Line 2694 sub metadata {
|
Line 3066 sub metadata {
|
| # |
# |
| # Importing a library here |
# Importing a library here |
| # |
# |
| if (defined($depthcount)) { $depthcount++; } else |
|
| { $depthcount=0; } |
|
| if ($depthcount<20) { |
if ($depthcount<20) { |
| foreach (split(/\,/,&metadata($uri,'keys', |
my $location=$parser->get_text('/import'); |
| $parser->get_text('/import'),$unikey, |
my $dir=$filename; |
| $depthcount))) { |
$dir=~s|[^/]*$||; |
| |
$location=&filelocation($dir,$location); |
| |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| |
$location,$unikey, |
| |
$depthcount+1)))) { |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
|
Line 2724 sub metadata {
|
Line 3098 sub metadata {
|
| # the next is the end of "start tag" |
# the next is the end of "start tag" |
| } |
} |
| } |
} |
| &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); |
|
| $metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
$metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
| |
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri); |
| |
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); |
| $metacache{$uri.':cachedtimestamp'}=time; |
$metacache{$uri.':cachedtimestamp'}=time; |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
|
Line 2760 sub metadata_generate_part0 {
|
Line 3135 sub metadata_generate_part0 {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------------- Get the title of a resource |
| |
|
| |
sub gettitle { |
| |
my $urlsymb=shift; |
| |
my $symb=&symbread($urlsymb); |
| |
unless ($symb) { |
| |
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
| |
return &metadata($urlsymb,'title'); |
| |
} |
| |
if ($titlecache{$symb}) { return $titlecache{$symb}; } |
| |
my ($map,$resid,$url)=split(/\_\_\_/,$symb); |
| |
my $title=''; |
| |
my %bighash; |
| |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| |
&GDBM_READER(),0640)) { |
| |
my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
| |
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
| |
untie %bighash; |
| |
} |
| |
if ($title) { |
| |
$titlecache{$symb}=$title; |
| |
return $title; |
| |
} else { |
| |
return &metadata($urlsymb,'title'); |
| |
} |
| |
} |
| |
|
| # ------------------------------------------------- Update symbolic store links |
# ------------------------------------------------- Update symbolic store links |
| |
|
| sub symblist { |
sub symblist { |
|
Line 2797 sub symbverify {
|
Line 3199 sub symbverify {
|
| my $okay=0; |
my $okay=0; |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
| my $ids=$bighash{'ids_/res/'.$thisfn}; |
my $ids=$bighash{'ids_'.&clutter($thisfn)}; |
| unless ($ids) { |
unless ($ids) { |
| $ids=$bighash{'ids_/'.$thisfn}; |
$ids=$bighash{'ids_/'.$thisfn}; |
| } |
} |
|
Line 2868 sub symbread {
|
Line 3270 sub symbread {
|
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
| # ---------------------------------------------- Get ID(s) for current resource |
# ---------------------------------------------- Get ID(s) for current resource |
| my $ids=$bighash{'ids_/res/'.$thisfn}; |
my $ids=$bighash{'ids_'.&clutter($thisfn)}; |
| unless ($ids) { |
unless ($ids) { |
| $ids=$bighash{'ids_/'.$thisfn}; |
$ids=$bighash{'ids_/'.$thisfn}; |
| } |
} |
|
Line 2975 sub receipt {
|
Line 3377 sub receipt {
|
| # ------------------------------------------------------------ Serves up a file |
# ------------------------------------------------------------ Serves up a file |
| # returns either the contents of the file or a -1 |
# returns either the contents of the file or a -1 |
| sub getfile { |
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); |
&repcopy($file); |
| if (! -e $file ) { return -1; }; |
if (! -e $file ) { return -1; }; |
| my $fh=Apache::File->new($file); |
my $fh=Apache::File->new($file); |
| my $a=''; |
my $a=''; |
| while (<$fh>) { $a .=$_; } |
while (<$fh>) { $a .=$_; } |
| return $a |
return $a; |
| |
} |
| } |
} |
| |
|
| sub filelocation { |
sub filelocation { |
|
Line 2991 sub filelocation {
|
Line 3404 sub filelocation {
|
| if ($file=~m:^/~:) { # is a contruction space reference |
if ($file=~m:^/~:) { # is a contruction space reference |
| $location = $file; |
$location = $file; |
| $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
| |
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
| |
$location=$file; |
| } else { |
} else { |
| $file=~s/^$perlvar{'lonDocRoot'}//; |
$file=~s/^$perlvar{'lonDocRoot'}//; |
| $file=~s:^/*res::; |
$file=~s:^/*res::; |
|
Line 3028 sub declutter {
|
Line 3443 sub declutter {
|
| return $thisfn; |
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 |
# -------------------------------------------------------- Escape Special Chars |
| |
|
| sub escape { |
sub escape { |
|
Line 3083 BEGIN {
|
Line 3508 BEGIN {
|
| my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| |
next if ($configline =~ /^(\#|\s*$)/); |
| chomp($configline); |
chomp($configline); |
| my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); |
| if ($id && $domain && $role && $name && $ip) { |
if ($id && $domain && $role && $name && $ip) { |
| $hostname{$id}=$name; |
$hostname{$id}=$name; |
| $hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
| $hostip{$id}=$ip; |
$hostip{$id}=$ip; |
| |
$iphost{$ip}=$id; |
| if ($domdescr) { $domaindescription{$domain}=$domdescr; } |
if ($domdescr) { $domaindescription{$domain}=$domdescr; } |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
| } else { |
} else { |
|
Line 3105 BEGIN {
|
Line 3532 BEGIN {
|
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
| if (($configline) && ($configline ne $perlvar{'lonHostID'})) { |
if ($configline) { |
| $spareid{$configline}=1; |
$spareid{$configline}=1; |
| } |
} |
| } |
} |
|
Line 3153 BEGIN {
|
Line 3580 BEGIN {
|
| |
|
| %metacache=(); |
%metacache=(); |
| |
|
| $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
| |
|
| &logtouch(); |
&logtouch(); |
|
Line 3369 modify user
|
Line 3796 modify user
|
| |
|
| =item * |
=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 * |
=item * |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl