|
version 1.255, 2002/07/30 19:57:40
|
version 1.294, 2002/10/09 17:24:06
|
|
Line 86 use GDBM_File;
|
Line 86 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 348 sub delenv {
|
Line 350 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 608 sub userenvironment {
|
Line 634 sub userenvironment {
|
| return %returnhash; |
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 |
# ----------------------------- Subscribe to a resource, return URL if possible |
| |
|
| sub subscribe { |
sub subscribe { |
|
Line 616 sub subscribe {
|
Line 678 sub subscribe {
|
| $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 647 sub repcopy {
|
Line 709 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 682 sub repcopy {
|
Line 749 sub repcopy {
|
| rename($transname,$filename); |
rename($transname,$filename); |
| return OK; |
return OK; |
| } |
} |
| |
} |
| } |
} |
| } |
} |
| |
|
|
Line 712 sub ssi {
|
Line 780 sub ssi {
|
| |
|
| sub tokenwrapper { |
sub tokenwrapper { |
| my $uri=shift; |
my $uri=shift; |
| my $token=&reply('tmpput:'.&escape($uri),$perlvar{'lonHostID'}); |
$uri=~s/^http\:\/\/([^\/]+)//; |
| return $uri.(($uri=~/\?/)?'&':'?'). |
$uri=~s/^\///; |
| 'token='.$token.'&server='.$perlvar{'lonHostID'}; |
$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 |
| |
# |
| |
if |
| |
(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok') |
| |
{ |
| |
# |
| |
# Return the URL to it |
| |
return '/uploaded/'.$path.$fname; |
| |
} else { |
| |
return '/adm/notfound.html'; |
| |
} |
| |
} |
| |
|
| # ------------------------------------------------------------------------- Log |
# ------------------------------------------------------------------------- Log |
| |
|
|
Line 749 sub flushcourselogs {
|
Line 882 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 794 sub countacc {
|
Line 927 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 929 sub devalidate {
|
Line 1062 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 1043 sub tmpreset {
|
Line 1274 sub tmpreset {
|
| my %hash; |
my %hash; |
| if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
| $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
| &GDBM_WRCREAT,0640)) { |
&GDBM_WRCREAT(),0640)) { |
| foreach my $key (keys %hash) { |
foreach my $key (keys %hash) { |
| if ($key=~ /:$symb/) { |
if ($key=~ /:$symb/) { |
| delete($hash{$key}); |
delete($hash{$key}); |
|
Line 1079 sub tmpstore {
|
Line 1310 sub tmpstore {
|
| my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=$perlvar{'lonDaemons'}.'/tmp'; |
| if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
| $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
| &GDBM_WRCREAT,0640)) { |
&GDBM_WRCREAT(),0640)) { |
| $hash{"version:$symb"}++; |
$hash{"version:$symb"}++; |
| my $version=$hash{"version:$symb"}; |
my $version=$hash{"version:$symb"}; |
| my $allkeys=''; |
my $allkeys=''; |
|
Line 1123 sub tmprestore {
|
Line 1354 sub tmprestore {
|
| my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=$perlvar{'lonDaemons'}.'/tmp'; |
| if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
| $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
| &GDBM_READER,0640)) { |
&GDBM_READER(),0640)) { |
| my $version=$hash{"version:$symb"}; |
my $version=$hash{"version:$symb"}; |
| $returnhash{'version'}=$version; |
$returnhash{'version'}=$version; |
| my $scope; |
my $scope; |
|
Line 1266 sub coursedescription {
|
Line 1497 sub coursedescription {
|
| 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.'.last_cache'}=time; |
|
Line 1394 sub get {
|
Line 1625 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 1526 sub allowed {
|
Line 1760 sub allowed {
|
| return ''; |
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=''; |
my $thisallowed=''; |
|
Line 1773 sub is_on_map {
|
Line 2018 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 1957 sub modifyuserauth {
|
Line 2203 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 1988 sub modifyuser {
|
Line 2235 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 2074 sub modifystudent {
|
Line 2322 sub modifystudent {
|
| return 'error: no such user'; |
return 'error: no such user'; |
| } |
} |
| # -------------------------------------------------- Add student to course list |
# -------------------------------------------------- Add student to course list |
| |
if ($first eq '' || $last eq '' || $uid eq '') { |
| |
# They did not supply us with enough data to enroll the student, so |
| |
# we need to pick up more information. |
| |
my %tmp = dump('environment',$udom,$uname, |
| |
['firstname','middlename','lastname', 'generation','id'] |
| |
); |
| |
$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{'genename'} if (!defined($gene) || $gene eq ''); |
| |
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
| |
} |
| |
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, |
| |
$first,$middle); |
| $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. |
$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; |
|
Line 2113 sub writecoursepref {
|
Line 2375 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 2135 sub createcourse {
|
Line 2394 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 2246 sub dirlist {
|
Line 2530 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 2298 sub condval {
|
Line 2606 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 2319 sub courseresdata {
|
Line 2635 sub courseresdata {
|
| } |
} |
| } |
} |
| 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 2470 sub EXT {
|
Line 2786 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=(); |
| my $thisparm=''; |
my $thisparm=''; |
| if (tie(%parmhash,'GDBM_File', |
if (tie(%parmhash,'GDBM_File', |
| $ENV{'request.course.fn'}.'_parms.db', |
$ENV{'request.course.fn'}.'_parms.db', |
| &GDBM_READER,0640)) { |
&GDBM_READER(),0640)) { |
| $thisparm=$parmhash{$symbparm}; |
$thisparm=$parmhash{$symbparm}; |
| untie(%parmhash); |
untie(%parmhash); |
| } |
} |
|
Line 2486 sub EXT {
|
Line 2802 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 2498 sub EXT {
|
Line 2820 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 2531 sub metadata {
|
Line 2853 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 2538 sub metadata {
|
Line 2865 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 2561 sub metadata {
|
Line 2888 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 2619 sub metadata {
|
Line 2946 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 2650 sub metadata {
|
Line 2979 sub metadata {
|
| } |
} |
| } |
} |
| $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 |
| } |
} |
| return $metacache{$uri.':'.$what}; |
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 |
# ------------------------------------------------- Update symbolic store links |
| |
|
| sub symblist { |
sub symblist { |
|
Line 2664 sub symblist {
|
Line 3023 sub symblist {
|
| my %hash; |
my %hash; |
| if (($ENV{'request.course.fn'}) && (%newhash)) { |
if (($ENV{'request.course.fn'}) && (%newhash)) { |
| if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
| &GDBM_WRCREAT,0640)) { |
&GDBM_WRCREAT(),0640)) { |
| foreach (keys %newhash) { |
foreach (keys %newhash) { |
| $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; |
$hash{declutter($_)}=$mapname.'___'.$newhash{$_}; |
| } |
} |
|
Line 2692 sub symbverify {
|
Line 3051 sub symbverify {
|
| my %bighash; |
my %bighash; |
| 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 2746 sub symbread {
|
Line 3105 sub symbread {
|
| my $syval=''; |
my $syval=''; |
| if (($ENV{'request.course.fn'}) && ($thisfn)) { |
if (($ENV{'request.course.fn'}) && ($thisfn)) { |
| if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
| &GDBM_READER,0640)) { |
&GDBM_READER(),0640)) { |
| $syval=$hash{$thisfn}; |
$syval=$hash{$thisfn}; |
| untie(%hash); |
untie(%hash); |
| } |
} |
|
Line 2762 sub symbread {
|
Line 3121 sub symbread {
|
| } else { |
} else { |
| # ------------------------------------------------------- Was not in symb table |
# ------------------------------------------------------- Was not in symb table |
| 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 2864 sub ireceipt {
|
Line 3223 sub ireceipt {
|
| } |
} |
| |
|
| sub receipt { |
sub receipt { |
| return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, |
my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); |
| $ENV{'request.course.id'},&symbread()); |
return &ireceipt($name,$domain,$courseid,$symb); |
| } |
} |
| |
|
| # ------------------------------------------------------------ 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 2887 sub filelocation {
|
Line 3257 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 2924 sub declutter {
|
Line 3296 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 3001 BEGIN {
|
Line 3383 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 3049 BEGIN {
|
Line 3431 BEGIN {
|
| |
|
| %metacache=(); |
%metacache=(); |
| |
|
| $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
| |
|
| &logtouch(); |
&logtouch(); |
|
Line 3265 modify user
|
Line 3647 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 |
| |
|
| |
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 * |
=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