|
version 1.637, 2005/06/11 13:38:47
|
version 1.674, 2005/11/01 15:07:29
|
|
Line 37 use HTTP::Date;
|
Line 37 use HTTP::Date;
|
| use vars |
use vars |
| qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom |
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom |
| %libserv %pr %prp $memcache %packagetab |
%libserv %pr %prp $memcache %packagetab |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf |
| %domaindescription %domain_auth_def %domain_auth_arg_def |
%domaindescription %domain_auth_def %domain_auth_arg_def |
| %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit |
|
Line 166 sub reply {
|
Line 166 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=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
| &logthis("<font color=blue>WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
| " $cmd to $server returned $answer</font>"); |
" $cmd to $server returned $answer</font>"); |
| } |
} |
| return $answer; |
return $answer; |
|
Line 190 sub reconlonc {
|
Line 190 sub reconlonc {
|
| sleep 5; |
sleep 5; |
| if (-e "$peerfile") { return; } |
if (-e "$peerfile") { return; } |
| &logthis( |
&logthis( |
| "<font color=blue>WARNING: $peerfile still not there, giving up</font>"); |
"<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>"); |
| } else { |
} else { |
| &logthis( |
&logthis( |
| "<font color=blue>WARNING:". |
"<font color=\"blue\">WARNING:". |
| " lonc at pid $loncpid not responding, giving up</font>"); |
" lonc at pid $loncpid not responding, giving up</font>"); |
| } |
} |
| } else { |
} else { |
| &logthis('<font color=blue>WARNING: lonc not running, giving up</font>'); |
&logthis('<font color="blue">WARNING: lonc not running, giving up</font>'); |
| } |
} |
| } |
} |
| |
|
|
Line 206 sub reconlonc {
|
Line 206 sub reconlonc {
|
| sub critical { |
sub critical { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| unless ($hostname{$server}) { |
unless ($hostname{$server}) { |
| &logthis("<font color=blue>WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
| " Critical message to unknown server ($server)</font>"); |
" Critical message to unknown server ($server)</font>"); |
| return 'no_such_host'; |
return 'no_such_host'; |
| } |
} |
|
Line 240 sub critical {
|
Line 240 sub critical {
|
| } |
} |
| chomp($wcmd); |
chomp($wcmd); |
| if ($wcmd eq $cmd) { |
if ($wcmd eq $cmd) { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Connection buffer $dfilename: $cmd</font>"); |
"Connection buffer $dfilename: $cmd</font>"); |
| &logperm("D:$server:$cmd"); |
&logperm("D:$server:$cmd"); |
| return 'con_delayed'; |
return 'con_delayed'; |
| } else { |
} else { |
| &logthis("<font color=red>CRITICAL:" |
&logthis("<font color=\"red\">CRITICAL:" |
| ." Critical connection failed: $server $cmd</font>"); |
." Critical connection failed: $server $cmd</font>"); |
| &logperm("F:$server:$cmd"); |
&logperm("F:$server:$cmd"); |
| return 'con_failed'; |
return 'con_failed'; |
|
Line 290 sub appenv {
|
Line 290 sub appenv {
|
| my %newenv=@_; |
my %newenv=@_; |
| foreach (keys %newenv) { |
foreach (keys %newenv) { |
| if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Attempt to modify environment ".$_." to ".$newenv{$_} |
"Attempt to modify environment ".$_." to ".$newenv{$_} |
| .'</font>'); |
.'</font>'); |
| delete($newenv{$_}); |
delete($newenv{$_}); |
|
Line 304 sub appenv {
|
Line 304 sub appenv {
|
| return 'error: '.$!; |
return 'error: '.$!; |
| } |
} |
| unless (flock($lockfh,LOCK_EX)) { |
unless (flock($lockfh,LOCK_EX)) { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| 'Could not obtain exclusive lock in appenv: '.$!); |
'Could not obtain exclusive lock in appenv: '.$!); |
| close($lockfh); |
close($lockfh); |
| return 'error: '.$!; |
return 'error: '.$!; |
|
Line 349 sub delenv {
|
Line 349 sub delenv {
|
| my $delthis=shift; |
my $delthis=shift; |
| my %newenv=(); |
my %newenv=(); |
| if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
| return 'error'; |
return 'error'; |
| } |
} |
|
Line 360 sub delenv {
|
Line 360 sub delenv {
|
| return 'error'; |
return 'error'; |
| } |
} |
| unless (flock($fh,LOCK_SH)) { |
unless (flock($fh,LOCK_SH)) { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| 'Could not obtain shared lock in delenv: '.$!); |
'Could not obtain shared lock in delenv: '.$!); |
| close($fh); |
close($fh); |
| return 'error: '.$!; |
return 'error: '.$!; |
|
Line 374 sub delenv {
|
Line 374 sub delenv {
|
| return 'error'; |
return 'error'; |
| } |
} |
| unless (flock($fh,LOCK_EX)) { |
unless (flock($fh,LOCK_EX)) { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| 'Could not obtain exclusive lock in delenv: '.$!); |
'Could not obtain exclusive lock in delenv: '.$!); |
| close($fh); |
close($fh); |
| return 'error: '.$!; |
return 'error: '.$!; |
|
Line 443 sub overloaderror {
|
Line 443 sub overloaderror {
|
| # ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
| |
|
| sub spareserver { |
sub spareserver { |
| my ($loadpercent,$userloadpercent) = @_; |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
| my $tryserver; |
my $tryserver; |
| my $spareserver=''; |
my $spareserver=''; |
| if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
| my $lowestserver=$loadpercent > $userloadpercent? |
my $lowestserver=$loadpercent > $userloadpercent? |
| $loadpercent : $userloadpercent; |
$loadpercent : $userloadpercent; |
| foreach $tryserver (keys %spareid) { |
foreach $tryserver (keys(%spareid)) { |
| my $loadans=reply('load',$tryserver); |
my $loadans=&reply('load',$tryserver); |
| my $userloadans=reply('userload',$tryserver); |
my $userloadans=&reply('userload',$tryserver); |
| if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
| next; #didn't get a number from the server |
next; #didn't get a number from the server |
| } |
} |
|
Line 468 sub spareserver {
|
Line 468 sub spareserver {
|
| $answer = $userloadans; |
$answer = $userloadans; |
| } |
} |
| if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
| $spareserver="http://$hostname{$tryserver}"; |
if ($want_server_name) { |
| |
$spareserver=$tryserver; |
| |
} else { |
| |
$spareserver="http://$hostname{$tryserver}"; |
| |
} |
| $lowestserver=$answer; |
$lowestserver=$answer; |
| } |
} |
| } |
} |
|
Line 767 sub validate_access_key {
|
Line 771 sub validate_access_key {
|
| } |
} |
| |
|
| # ------------------------------------- Find the section of student in a course |
# ------------------------------------- Find the section of student in a course |
| |
sub devalidate_getsection_cache { |
| |
my ($udom,$unam,$courseid)=@_; |
| |
$courseid=~s/\_/\//g; |
| |
$courseid=~s/^(\w)/\/$1/; |
| |
my $hashid="$udom:$unam:$courseid"; |
| |
&devalidate_cache_new('getsection',$hashid); |
| |
} |
| |
|
| sub getsection { |
sub getsection { |
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
|
Line 1053 sub repcopy {
|
Line 1064 sub repcopy {
|
| if ($response->is_error()) { |
if ($response->is_error()) { |
| unlink($transname); |
unlink($transname); |
| my $message=$response->status_line; |
my $message=$response->status_line; |
| &logthis("<font color=blue>WARNING:" |
&logthis("<font color=\"blue\">WARNING:" |
| ." LWP get: $message: $filename</font>"); |
." LWP get: $message: $filename</font>"); |
| return 'unavailable'; |
return 'unavailable'; |
| } else { |
} else { |
|
Line 1063 sub repcopy {
|
Line 1074 sub repcopy {
|
| if ($mresponse->is_error()) { |
if ($mresponse->is_error()) { |
| unlink($filename.'.meta'); |
unlink($filename.'.meta'); |
| &logthis( |
&logthis( |
| "<font color=yellow>INFO: No metadata: $filename</font>"); |
"<font color=\"yellow\">INFO: No metadata: $filename</font>"); |
| } |
} |
| } |
} |
| rename($transname,$filename); |
rename($transname,$filename); |
|
Line 1132 sub allowuploaded {
|
Line 1143 sub allowuploaded {
|
| } |
} |
| |
|
| # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
| # input: action, courseID, current domain, home server for course, intended |
# input: action, courseID, current domain, intended |
| # path to file, source of file, instruction to parse file for objects, |
# path to file, source of file, instruction to parse file for objects, |
| # ref to hash for embedded objects, |
# ref to hash for embedded objects, |
| # ref to hash for codebase of java objects. |
# ref to hash for codebase of java objects. |
|
Line 1162 sub allowuploaded {
|
Line 1173 sub allowuploaded {
|
| # |
# |
| |
|
| sub process_coursefile { |
sub process_coursefile { |
| my ($action,$docuname,$docudom,$docuhome,$file,$source,$parser,$allfiles,$codebase)=@_; |
my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_; |
| my $fetchresult; |
my $fetchresult; |
| |
my $home=&homeserver($docuname,$docudom); |
| if ($action eq 'propagate') { |
if ($action eq 'propagate') { |
| $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
| ,$docuhome); |
$home); |
| } else { |
} else { |
| my $fetchresult = ''; |
|
| my $fpath = ''; |
my $fpath = ''; |
| my $fname = $file; |
my $fname = $file; |
| ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
|
Line 1182 sub process_coursefile {
|
Line 1193 sub process_coursefile {
|
| my $destination = $filepath.'/'.$fname; |
my $destination = $filepath.'/'.$fname; |
| rename($source,$destination); |
rename($source,$destination); |
| $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
| $docuhome); |
$home); |
| } |
} |
| } elsif ($action eq 'uploaddoc') { |
} elsif ($action eq 'uploaddoc') { |
| open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>'.$filepath.'/'.$fname); |
|
Line 1195 sub process_coursefile {
|
Line 1206 sub process_coursefile {
|
| } |
} |
| } |
} |
| $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
| $docuhome); |
$home); |
| if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
| return '/uploaded/'.$fpath.'/'.$fname; |
return '/uploaded/'.$fpath.'/'.$fname; |
| } else { |
} else { |
| &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
| ' to host '.$docuhome.': '.$fetchresult); |
' to host '.$home.': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
| } |
} |
| unless ( $fetchresult eq 'ok') { |
unless ( $fetchresult eq 'ok') { |
| &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
| ' to host '.$docuhome.': '.$fetchresult); |
' to host '.$home.': '.$fetchresult); |
| } |
} |
| return $fetchresult; |
return $fetchresult; |
| } |
} |
|
Line 1228 sub build_filepath {
|
Line 1239 sub build_filepath {
|
| } |
} |
| |
|
| sub store_edited_file { |
sub store_edited_file { |
| my ($primary_url,$content,$docudom,$docuname,$docuhome,$fetchresult) = @_; |
my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_; |
| my $file = $primary_url; |
my $file = $primary_url; |
| $file =~ s#^/uploaded/$docudom/$docuname/##; |
$file =~ s#^/uploaded/$docudom/$docuname/##; |
| my $fpath = ''; |
my $fpath = ''; |
|
Line 1239 sub store_edited_file {
|
Line 1250 sub store_edited_file {
|
| open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>'.$filepath.'/'.$fname); |
| print $fh $content; |
print $fh $content; |
| close($fh); |
close($fh); |
| |
my $home=&homeserver($docuname,$docudom); |
| $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
| $docuhome); |
$home); |
| if ($$fetchresult eq 'ok') { |
if ($$fetchresult eq 'ok') { |
| return '/uploaded/'.$fpath.'/'.$fname; |
return '/uploaded/'.$fpath.'/'.$fname; |
| } else { |
} else { |
| &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. ' to host '.$docuhome.': '.$$fetchresult); |
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
| |
' to host '.$home.': '.$$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
|
Line 1295 sub userfileupload {
|
Line 1308 sub userfileupload {
|
| return $fullpath.'/'.$fname; |
return $fullpath.'/'.$fname; |
| } |
} |
| # Create the directory if not present |
# Create the directory if not present |
| my $docuname=''; |
|
| my $docudom=''; |
|
| my $docuhome=''; |
|
| $fname="$subdir/$fname"; |
$fname="$subdir/$fname"; |
| if ($coursedoc) { |
if ($coursedoc) { |
| $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
| $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
| $docuhome=$env{'course.'.$env{'request.course.id'}.'.home'}; |
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
| if ($env{'form.folder'} =~ m/^default/) { |
return &finishuserfileupload($docuname,$docudom, |
| return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase); |
$formname,$fname,$parser,$allfiles, |
| |
$codebase); |
| } else { |
} else { |
| $fname=$env{'form.folder'}.'/'.$fname; |
$fname=$env{'form.folder'}.'/'.$fname; |
| return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname,$parser,$allfiles,$codebase); |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
| |
$fname,$formname,$parser, |
| |
$allfiles,$codebase); |
| } |
} |
| } else { |
} else { |
| $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
| $docudom=$env{'user.domain'}; |
my $docudom=$env{'user.domain'}; |
| $docuhome=$env{'user.home'}; |
return &finishuserfileupload($docuname,$docudom,$formname, |
| return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase); |
$fname,$parser,$allfiles,$codebase); |
| } |
} |
| } |
} |
| |
|
| sub finishuserfileupload { |
sub finishuserfileupload { |
| my ($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase) = @_; |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| my ($fnamepath,$file); |
my ($fnamepath,$file); |
|
Line 1342 sub finishuserfileupload {
|
Line 1355 sub finishuserfileupload {
|
| close(FH); |
close(FH); |
| } |
} |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
| my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,$codebase); |
my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, |
| |
$codebase); |
| unless ($parse_result eq 'ok') { |
unless ($parse_result eq 'ok') { |
| &logthis('Failed to parse '.$filepath.$file.' for embedded media: '.$parse_result); |
&logthis('Failed to parse '.$filepath.$file. |
| |
' for embedded media: '.$parse_result); |
| } |
} |
| } |
} |
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| |
my $docuhome=&homeserver($docuname,$docudom); |
| my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
| if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
| # |
# |
|
Line 1362 sub finishuserfileupload {
|
Line 1378 sub finishuserfileupload {
|
| } |
} |
| |
|
| sub extract_embedded_items { |
sub extract_embedded_items { |
| my ($filepath,$file,$allfiles,$codebase) = @_; |
my ($filepath,$file,$allfiles,$codebase,$content) = @_; |
| my @state = (); |
my @state = (); |
| my %javafiles = ( |
my %javafiles = ( |
| codebase => '', |
codebase => '', |
|
Line 1373 sub extract_embedded_items {
|
Line 1389 sub extract_embedded_items {
|
| src => '', |
src => '', |
| movie => '', |
movie => '', |
| ); |
); |
| my $p = HTML::Parser->new |
my $p; |
| ( |
if ($content) { |
| xml_mode => 1, |
$p = HTML::LCParser->new($content); |
| start_h => |
} else { |
| [sub { |
$p = HTML::LCParser->new($filepath.'/'.$file); |
| my ($tagname, $attr) = @_; |
} |
| push (@state, $tagname); |
while (my $t=$p->get_token()) { |
| if (lc($tagname) eq 'img') { |
if ($t->[0] eq 'S') { |
| if (exists($$allfiles{$attr->{'src'}})) { |
my ($tagname, $attr) = ($t->[1],$t->[2]); |
| unless (grep/^src$/,@{$$allfiles{$attr->{'src'}}}) { |
push (@state, $tagname); |
| push (@{$$allfiles{$attr->{'src'}}},&escape('src')); |
if (lc($tagname) eq 'allow') { |
| } |
&add_filetype($allfiles,$attr->{'src'},'src'); |
| } else { |
} |
| @{$$allfiles{$attr->{'src'}}} = (&escape('src')); |
if (lc($tagname) eq 'img') { |
| } |
&add_filetype($allfiles,$attr->{'src'},'src'); |
| } |
} |
| if (lc($tagname) eq 'object') { |
if (lc($tagname) eq 'script') { |
| foreach my $item (keys (%javafiles)) { |
if ($attr->{'archive'} =~ /\.jar$/i) { |
| $javafiles{$item} = ''; |
&add_filetype($allfiles,$attr->{'archive'},'archive'); |
| } |
|
| } |
|
| if (lc($state[-2]) eq 'object') { |
|
| if (lc($tagname) eq 'param') { |
|
| my $name = lc($attr->{'name'}); |
|
| foreach my $item (keys (%mediafiles)) { |
|
| if ($name eq $item) { |
|
| if (exists($$allfiles{$attr->{'value'}})) { |
|
| unless(grep/^value$/,@{$$allfiles{$attr->{'value'}}}) { |
|
| push(@{$$allfiles{$attr->{'value'}}},&escape('value')); |
|
| } |
|
| } else { |
|
| @{$$allfiles{$attr->{'value'}}} = (&escape('value')); |
|
| } |
|
| last; |
|
| } |
|
| } |
|
| foreach my $item (keys (%javafiles)) { |
|
| if ($name eq $item) { |
|
| $javafiles{$item} = $attr->{'value'}; |
|
| last; |
|
| } |
|
| } |
|
| } |
|
| } |
|
| if (lc($tagname) eq 'embed') { |
|
| unless (lc($state[-2]) eq 'object') { |
|
| foreach my $item (keys (%javafiles)) { |
|
| $javafiles{$item} = ''; |
|
| } |
|
| } |
|
| foreach my $item (keys (%javafiles)) { |
|
| if ($attr->{$item}) { |
|
| $javafiles{$item} = $attr->{$item}; |
|
| last; |
|
| } |
|
| } |
|
| foreach my $item (keys (%mediafiles)) { |
|
| if ($attr->{$item}) { |
|
| if (exists($$allfiles{$attr->{$item}})) { |
|
| unless (grep/^$item$/,@{$$allfiles{$item}}) { |
|
| push(@{$$allfiles{$attr->{$item}}},&escape($item)); |
|
| } |
|
| } else { |
|
| @{$$allfiles{$attr->{$item}}} = (&escape($item)); |
|
| } |
|
| last; |
|
| } |
|
| } |
|
| } |
|
| }, "tagname, attr"], |
|
| text_h => |
|
| [sub { |
|
| my ($text) = @_; |
|
| }, "dtext"], |
|
| end_h => |
|
| [sub { |
|
| my ($tagname) = @_; |
|
| unless ($javafiles{'codebase'} eq '') { |
|
| $javafiles{'codebase'} .= '/'; |
|
| } |
|
| if (lc($tagname) eq 'object') { |
|
| &extract_java_items(\%javafiles,$allfiles,$codebase); |
|
| } |
|
| if (lc($tagname) eq 'embed') { |
|
| unless (lc($state[-2]) eq 'object') { |
|
| &extract_java_items(\%javafiles,$allfiles,$codebase); |
|
| } |
|
| } |
|
| pop @state; |
|
| }, "tagname"], |
|
| ); |
|
| $p->parse_file($filepath.'/'.$file); |
|
| $p->eof; |
|
| return 'ok'; |
|
| } |
|
| |
|
| sub extract_java_items { |
|
| my ($javafiles,$allfiles,$codebase) = @_; |
|
| foreach my $item (keys (%{$javafiles})) { |
|
| unless ($item eq 'codebase') { |
|
| if ($$javafiles{$item} ne '') { |
|
| if (exists($$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}})) { |
|
| unless (grep/^$item$/,@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}}) { |
|
| push(@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}},&escape($item)); |
|
| } |
|
| } else { |
} else { |
| @{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}} = (&escape($item)); |
&add_filetype($allfiles,$attr->{'src'},'src'); |
| $$codebase{$$javafiles{'codebase'}.$$javafiles{$item}} = $$javafiles{'codebase'}; |
|
| |
|
| } |
} |
| } |
} |
| } |
if (lc($tagname) eq 'link') { |
| |
if (lc($attr->{'rel'}) eq 'stylesheet') { |
| |
&add_filetype($allfiles,$attr->{'href'},'href'); |
| |
} |
| |
} |
| |
if (lc($tagname) eq 'object' || |
| |
(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) { |
| |
foreach my $item (keys(%javafiles)) { |
| |
$javafiles{$item} = ''; |
| |
} |
| |
} |
| |
if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { |
| |
my $name = lc($attr->{'name'}); |
| |
foreach my $item (keys(%javafiles)) { |
| |
if ($name eq $item) { |
| |
$javafiles{$item} = $attr->{'value'}; |
| |
last; |
| |
} |
| |
} |
| |
foreach my $item (keys(%mediafiles)) { |
| |
if ($name eq $item) { |
| |
&add_filetype($allfiles, $attr->{'value'}, 'value'); |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { |
| |
foreach my $item (keys(%javafiles)) { |
| |
if ($attr->{$item}) { |
| |
$javafiles{$item} = $attr->{$item}; |
| |
last; |
| |
} |
| |
} |
| |
foreach my $item (keys(%mediafiles)) { |
| |
if ($attr->{$item}) { |
| |
&add_filetype($allfiles,$attr->{$item},$item); |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} elsif ($t->[0] eq 'E') { |
| |
my ($tagname) = ($t->[1]); |
| |
if ($javafiles{'codebase'} ne '') { |
| |
$javafiles{'codebase'} .= '/'; |
| |
} |
| |
if (lc($tagname) eq 'applet' || |
| |
lc($tagname) eq 'object' || |
| |
(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object') |
| |
) { |
| |
foreach my $item (keys(%javafiles)) { |
| |
if ($item ne 'codebase' && $javafiles{$item} ne '') { |
| |
my $file=$javafiles{'codebase'}.$javafiles{$item}; |
| |
&add_filetype($allfiles,$file,$item); |
| |
} |
| |
} |
| |
} |
| |
pop @state; |
| |
} |
| |
} |
| |
return 'ok'; |
| |
} |
| |
|
| |
sub add_filetype { |
| |
my ($allfiles,$file,$type)=@_; |
| |
if (exists($allfiles->{$file})) { |
| |
unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) { |
| |
push(@{$allfiles->{$file}}, &escape($type)); |
| |
} |
| |
} else { |
| |
@{$allfiles->{$file}} = (&escape($type)); |
| } |
} |
| } |
} |
| |
|
|
Line 1545 sub flushcourselogs {
|
Line 1542 sub flushcourselogs {
|
| } else { |
} else { |
| &logthis('Failed to flush log buffer for '.$crsid); |
&logthis('Failed to flush log buffer for '.$crsid); |
| if (length($courselogs{$crsid})>40000) { |
if (length($courselogs{$crsid})>40000) { |
| &logthis("<font color=blue>WARNING: Buffer for ".$crsid. |
&logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid. |
| " exceeded maximum size, deleting.</font>"); |
" exceeded maximum size, deleting.</font>"); |
| delete $courselogs{$crsid}; |
delete $courselogs{$crsid}; |
| } |
} |
|
Line 1616 sub flushcourselogs {
|
Line 1613 sub flushcourselogs {
|
| delete $userrolehash{$entry}; |
delete $userrolehash{$entry}; |
| } |
} |
| } |
} |
| |
# |
| |
# Reverse lookup of domain roles (dc, ad, li, sc, au) |
| |
# |
| |
my %domrolebuffer = (); |
| |
foreach my $entry (keys %domainrolehash) { |
| |
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry; |
| |
if ($domrolebuffer{$rudom}) { |
| |
$domrolebuffer{$rudom}.='&'.&escape($entry). |
| |
'='.&escape($domainrolehash{$entry}); |
| |
} else { |
| |
$domrolebuffer{$rudom}.=&escape($entry). |
| |
'='.&escape($domainrolehash{$entry}); |
| |
} |
| |
delete $domainrolehash{$entry}; |
| |
} |
| |
foreach my $dom (keys(%domrolebuffer)) { |
| |
foreach my $tryserver (keys %libserv) { |
| |
if ($hostdom{$tryserver} eq $dom) { |
| |
unless (&reply('domroleput:'.$dom.':'. |
| |
$domrolebuffer{$dom},$tryserver) eq 'ok') { |
| |
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
| |
} |
| |
} |
| |
} |
| |
} |
| $dumpcount++; |
$dumpcount++; |
| } |
} |
| |
|
|
Line 1649 sub courseacclog {
|
Line 1671 sub courseacclog {
|
| my $fnsymb=shift; |
my $fnsymb=shift; |
| unless ($env{'request.course.id'}) { return ''; } |
unless ($env{'request.course.id'}) { return ''; } |
| my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; |
my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; |
| if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { |
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { |
| $what.=':POST'; |
$what.=':POST'; |
| # FIXME: Probably ought to escape things.... |
# FIXME: Probably ought to escape things.... |
| foreach (keys %env) { |
foreach (keys %env) { |
|
Line 1691 sub linklog {
|
Line 1713 sub linklog {
|
| |
|
| sub userrolelog { |
sub userrolelog { |
| my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
| if (($trole=~/^ca/) || ($trole=~/^in/) || |
if (($trole=~/^ca/) || ($trole=~/^aa/) || |
| ($trole=~/^cc/) || ($trole=~/^ep/) || |
($trole=~/^in/) || ($trole=~/^cc/) || |
| ($trole=~/^cr/) || ($trole=~/^ta/)) { |
($trole=~/^ep/) || ($trole=~/^cr/) || |
| |
($trole=~/^ta/)) { |
| my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| $userrolehash |
$userrolehash |
| {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
| =$tend.':'.$tstart; |
=$tend.':'.$tstart; |
| } |
} |
| |
if (($trole=~/^dc/) || ($trole=~/^ad/) || |
| |
($trole=~/^li/) || ($trole=~/^li/) || |
| |
($trole=~/^au/) || ($trole=~/^dg/) || |
| |
($trole=~/^sc/)) { |
| |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| |
$domainrolehash |
| |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
| |
= $tend.':'.$tstart; |
| |
} |
| } |
} |
| |
|
| sub get_course_adv_roles { |
sub get_course_adv_roles { |
|
Line 1722 sub get_course_adv_roles {
|
Line 1754 sub get_course_adv_roles {
|
| if ($username eq '' || $domain eq '') { next; } |
if ($username eq '' || $domain eq '') { next; } |
| if ((&privileged($username,$domain)) && |
if ((&privileged($username,$domain)) && |
| (!$nothide{$username.':'.$domain})) { next; } |
(!$nothide{$username.':'.$domain})) { next; } |
| |
if ($role eq 'cr') { next; } |
| my $key=&plaintext($role); |
my $key=&plaintext($role); |
| |
if ($role =~ /^cr/) { |
| |
$key=(split('/',$role))[3]; |
| |
} |
| if ($section) { $key.=' (Sec/Grp '.$section.')'; } |
if ($section) { $key.=' (Sec/Grp '.$section.')'; } |
| if ($returnhash{$key}) { |
if ($returnhash{$key}) { |
| $returnhash{$key}.=','.$username.':'.$domain; |
$returnhash{$key}.=','.$username.':'.$domain; |
|
Line 1813 sub courseiddump {
|
Line 1849 sub courseiddump {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| # |
# ---------------------------------------------------------- DC e-mail |
| |
|
| |
sub dcmailput { |
| |
my ($domain,$msgid,$contents,$server)=@_; |
| |
my $status = &Apache::lonnet::critical( |
| |
'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='. |
| |
&Apache::lonnet::escape($$contents{$server}),$server); |
| |
return $status; |
| |
} |
| |
|
| |
sub dcmaildump { |
| |
my ($dom,$startdate,$enddate,$senders) = @_; |
| |
my %returnhash=(); |
| |
foreach my $tryserver (keys(%libserv)) { |
| |
if ($hostdom{$tryserver} eq $dom) { |
| |
%{$returnhash{$tryserver}}=(); |
| |
my $cmd='dcmaildump:'.$dom.':'. |
| |
&escape($startdate).':'.&escape($enddate).':'; |
| |
my @esc_senders=map { &escape($_)} @$senders; |
| |
$cmd.=&escape(join('&',@esc_senders)); |
| |
foreach (split(/\&/,&reply($cmd,$tryserver))) { |
| |
my ($key,$value) = split(/\=/,$_); |
| |
if (($key) && ($value)) { |
| |
$returnhash{$tryserver}{&unescape($key)} = &unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
# ---------------------------------------------------------- Domain roles |
| |
|
| |
sub get_domain_roles { |
| |
my ($dom,$roles,$startdate,$enddate)=@_; |
| |
if (undef($startdate) || $startdate eq '') { |
| |
$startdate = '.'; |
| |
} |
| |
if (undef($enddate) || $enddate eq '') { |
| |
$enddate = '.'; |
| |
} |
| |
my $rolelist = join(':',@{$roles}); |
| |
my %personnel = (); |
| |
foreach my $tryserver (keys(%libserv)) { |
| |
if ($hostdom{$tryserver} eq $dom) { |
| |
%{$personnel{$tryserver}}=(); |
| |
foreach ( |
| |
split(/\&/,&reply('domrolesdump:'.$dom.':'. |
| |
&escape($startdate).':'.&escape($enddate).':'. |
| |
&escape($rolelist), $tryserver))) { |
| |
my($key,$value) = split(/\=/,$_); |
| |
if (($key) && ($value)) { |
| |
$personnel{$tryserver}{&unescape($key)} = &unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %personnel; |
| |
} |
| |
|
| # ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Check out an item |
| |
|
| sub get_first_access { |
sub get_first_access { |
|
Line 1859 sub checkout {
|
Line 1953 sub checkout {
|
| $now.'&'.$ENV{'REMOTE_ADDR'}); |
$now.'&'.$ENV{'REMOTE_ADDR'}); |
| my $token=&reply('tmpput:'.$infostr,$lonhost); |
my $token=&reply('tmpput:'.$infostr,$lonhost); |
| if ($token=~/^error\:/) { |
if ($token=~/^error\:/) { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. |
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. |
| "</font>"); |
"</font>"); |
| return ''; |
return ''; |
|
Line 1875 sub checkout {
|
Line 1969 sub checkout {
|
| unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
| return ''; |
return ''; |
| } else { |
} else { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. |
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. |
| "</font>"); |
"</font>"); |
| } |
} |
|
Line 1885 sub checkout {
|
Line 1979 sub checkout {
|
| $token)) ne 'ok') { |
$token)) ne 'ok') { |
| return ''; |
return ''; |
| } else { |
} else { |
| &logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. |
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. |
| "</font>"); |
"</font>"); |
| } |
} |
|
Line 2488 sub rolesinit {
|
Line 2582 sub rolesinit {
|
| if ($_!~/^rolesdef_/) { |
if ($_!~/^rolesdef_/) { |
| my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
| $area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
| |
|
| my ($trole,$tend,$tstart); |
my ($trole,$tend,$tstart); |
| if ($role=~/^cr/) { |
if ($role=~/^cr/) { |
| ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); |
if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { |
| ($tend,$tstart)=split('_',$trest); |
($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); |
| |
($tend,$tstart)=split('_',$trest); |
| |
} else { |
| |
$trole=$role; |
| |
} |
| } else { |
} else { |
| ($trole,$tend,$tstart)=split(/_/,$role); |
($trole,$tend,$tstart)=split(/_/,$role); |
| } |
} |
|
Line 2508 sub rolesinit {
|
Line 2605 sub rolesinit {
|
| &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); |
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); |
| $userroles.='user.adv='.$adv."\n". |
$userroles.='user.adv='.$adv."\n". |
|
Line 2861 sub eget {
|
Line 2958 sub eget {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
# ------------------------------------------------------------ tmpput interface |
| |
sub tmpput { |
| |
my ($storehash,$server)=@_; |
| |
my $items=''; |
| |
foreach (keys(%$storehash)) { |
| |
$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
| |
} |
| |
$items=~s/\&$//; |
| |
return &reply("tmpput:$items",$server); |
| |
} |
| |
|
| |
# ------------------------------------------------------------ tmpget interface |
| |
sub tmpget { |
| |
my ($token)=@_; |
| |
my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'}); |
| |
my %returnhash; |
| |
foreach my $item (split(/\&/,$rep)) { |
| |
my ($key,$value)=split(/=/,$item); |
| |
$returnhash{&unescape($key)}=&thaw_unescape($value); |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| # ---------------------------------------------- Custom access rule evaluation |
# ---------------------------------------------- Custom access rule evaluation |
| |
|
| sub customaccess { |
sub customaccess { |
|
Line 2914 sub allowed {
|
Line 3034 sub allowed {
|
| |
|
| # Free bre access to user's own portfolio contents |
# Free bre access to user's own portfolio contents |
| my ($space,$domain,$name,$dir)=split('/',$uri); |
my ($space,$domain,$name,$dir)=split('/',$uri); |
| if (($space=~/^(uploaded|ediupload)$/) && ($env{'user.name'} eq $name) && |
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && |
| ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { |
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { |
| return 'F'; |
return 'F'; |
| } |
} |
|
Line 2982 sub allowed {
|
Line 3102 sub allowed {
|
| $thisallowed.=$1; |
$thisallowed.=$1; |
| } |
} |
| |
|
| # URI is an uploaded document for this course |
# URI is an uploaded document for this course, default permissions don't matter |
| # not allowing 'edit' access (editupload) to uploaded course docs |
# not allowing 'edit' access (editupload) to uploaded course docs |
| if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
| my $refuri=$env{'httpref.'.$orguri}; |
$thisallowed=''; |
| if ($refuri) { |
my ($match)=&is_on_map($uri); |
| if ($refuri =~ m|^/adm/|) { |
if ($match) { |
| $thisallowed='F'; |
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
| } |
=~/\Q$priv\E\&([^\:]*)/) { |
| } |
$thisallowed.=$1; |
| |
} |
| |
} else { |
| |
my $refuri=$env{'httpref.'.$orguri}; |
| |
if ($refuri) { |
| |
if ($refuri =~ m|^/adm/|) { |
| |
$thisallowed='F'; |
| |
} else { |
| |
$refuri=&declutter($refuri); |
| |
my ($match) = &is_on_map($refuri); |
| |
if ($match) { |
| |
$thisallowed='F'; |
| |
} |
| |
} |
| |
} |
| |
} |
| } |
} |
| |
|
| # Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
|
Line 3001 sub allowed {
|
Line 3136 sub allowed {
|
| |
|
| # If this is generating or modifying users, exit with special codes |
# If this is generating or modifying users, exit with special codes |
| |
|
| if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { |
if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) { |
| |
if (($priv eq 'cca') || ($priv eq 'caa')) { |
| |
my ($audom,$auname)=split('/',$uri); |
| |
# no author name given, so this just checks on the general right to make a co-author in this domain |
| |
unless ($auname) { return $thisallowed; } |
| |
# an author name is given, so we are about to actually make a co-author for a certain account |
| |
if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) || |
| |
(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) && |
| |
($audom ne $env{'request.role.domain'}))) { return ''; } |
| |
} |
| return $thisallowed; |
return $thisallowed; |
| } |
} |
| # |
# |
|
Line 3149 sub allowed {
|
Line 3293 sub allowed {
|
| my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
| if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
| =~/\Q$rolecode\E/) { |
=~/\Q$rolecode\E/) { |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
| 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
| $env{'request.course.id'}); |
$env{'request.course.id'}); |
| return ''; |
return ''; |
|
Line 3157 sub allowed {
|
Line 3301 sub allowed {
|
| |
|
| if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
| =~/\Q$unamedom\E/) { |
=~/\Q$unamedom\E/) { |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
| 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
| $env{'request.course.id'}); |
$env{'request.course.id'}); |
| return ''; |
return ''; |
|
Line 3169 sub allowed {
|
Line 3313 sub allowed {
|
| if ($thisallowed=~/R/) { |
if ($thisallowed=~/R/) { |
| my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
| if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
| 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
| return ''; |
return ''; |
| } |
} |
| } |
} |
|
Line 3197 sub allowed {
|
Line 3341 sub allowed {
|
| # --------------------------------------------------- Is a resource on the map? |
# --------------------------------------------------- Is a resource on the map? |
| |
|
| sub is_on_map { |
sub is_on_map { |
| my $uri=&declutter(shift); |
my $uri=&deversion(&declutter(shift)); |
| $uri=~s/\.\d+\.(\w+)$/\.$1/; |
|
| my @uriparts=split(/\//,$uri); |
my @uriparts=split(/\//,$uri); |
| my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
| my $pathname=$uri; |
my $pathname=$uri; |
|
Line 3568 sub assignrole {
|
Line 3711 sub assignrole {
|
| my $answer=&reply($command,&homeserver($uname,$udom)); |
my $answer=&reply($command,&homeserver($uname,$udom)); |
| # log new user role if status is ok |
# log new user role if status is ok |
| if ($answer eq 'ok') { |
if ($answer eq 'ok') { |
| &userrolelog($mrole,$uname,$udom,$url,$start,$end); |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
|
Line 3771 sub modify_student_enrollment {
|
Line 3914 sub modify_student_enrollment {
|
| $cdom,$cnum); |
$cdom,$cnum); |
| unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
| return 'error: '.$reply; |
return 'error: '.$reply; |
| |
} else { |
| |
&devalidate_getsection_cache($udom,$uname,$cid); |
| } |
} |
| # Add student role to user |
# Add student role to user |
| my $uurl='/'.$cid; |
my $uurl='/'.$cid; |
|
Line 3829 sub createcourse {
|
Line 3974 sub createcourse {
|
| return 'refused'; |
return 'refused'; |
| } |
} |
| # ------------------------------------------------------------------- Create ID |
# ------------------------------------------------------------------- Create ID |
| my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
my $uname=int(1+rand(9)). |
| |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
| |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
| unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
| # ----------------------------------------------- Make sure that does not exist |
# ----------------------------------------------- Make sure that does not exist |
| my $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
|
Line 3875 sub createcourse {
|
Line 4022 sub createcourse {
|
| </map> |
</map> |
| ENDINITMAP |
ENDINITMAP |
| $topurl=&declutter( |
$topurl=&declutter( |
| &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') |
&finishuserfileupload($uname,$udom,'initmap','default.sequence') |
| ); |
); |
| } |
} |
| # ----------------------------------------------------------- Write preferences |
# ----------------------------------------------------------- Write preferences |
|
Line 4078 sub unmark_as_readonly {
|
Line 4225 sub unmark_as_readonly {
|
| my ($tmp)=keys(%current_permissions); |
my ($tmp)=keys(%current_permissions); |
| if ($tmp=~/^error:/) { undef(%current_permissions); } |
if ($tmp=~/^error:/) { undef(%current_permissions); } |
| my @readonly_files = &get_marked_as_readonly($domain,$user,$what); |
my @readonly_files = &get_marked_as_readonly($domain,$user,$what); |
| foreach my $file(@readonly_files){ |
foreach my $file (@readonly_files) { |
| my $current_locks = $current_permissions{$file}; |
if (defined($file_name) && ($file_name ne $file)) { next; } |
| |
my $current_locks = $current_permissions{$file}; |
| my @new_locks; |
my @new_locks; |
| my @del_keys; |
my @del_keys; |
| if (ref($current_locks) eq "ARRAY"){ |
if (ref($current_locks) eq "ARRAY"){ |
| foreach my $locker (@{$current_locks}) { |
foreach my $locker (@{$current_locks}) { |
| my $compare=$locker; |
my $compare=$locker; |
| if (ref($locker)) { $compare=join('',@{$locker}) }; |
if (ref($locker)) { $compare=join('',@{$locker}) }; |
| if ($compare eq $symb_crs) { |
if ($compare ne $symb_crs) { |
| if (defined($file_name) && ($file_name ne $file)) { |
push(@new_locks, $locker); |
| push(@new_locks, $what); |
|
| } |
|
| } else { |
|
| push(@new_locks, $what); |
|
| } |
} |
| } |
} |
| if (@new_locks > 0) { |
if (scalar(@new_locks) > 0) { |
| $current_permissions{$file} = \@new_locks; |
$current_permissions{$file} = \@new_locks; |
| } else { |
} else { |
| push(@del_keys, $file); |
push(@del_keys, $file); |
| &del('file_permissions',\@del_keys, $domain, $user); |
&del('file_permissions',\@del_keys, $domain, $user); |
| delete $current_permissions{$file}; |
delete($current_permissions{$file}); |
| } |
} |
| } |
} |
| } |
} |
|
Line 4340 sub get_userresdata {
|
Line 4484 sub get_userresdata {
|
| } |
} |
| #error 2 occurs when the .db doesn't exist |
#error 2 occurs when the .db doesn't exist |
| if ($tmp!~/error: 2 /) { |
if ($tmp!~/error: 2 /) { |
| &logthis("<font color=blue>WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
| " Trying to get resource data for ". |
" Trying to get resource data for ". |
| $uname." at ".$udom.": ". |
$uname." at ".$udom.": ". |
| $tmp."</font>"); |
$tmp."</font>"); |
|
Line 4427 sub EXT {
|
Line 4571 sub EXT {
|
| if ($realm eq 'user') { |
if ($realm eq 'user') { |
| # --------------------------------------------------------------- user.resource |
# --------------------------------------------------------------- user.resource |
| if ($space eq 'resource') { |
if ($space eq 'resource') { |
| if (defined($Apache::lonhomework::parsing_a_problem) || |
if ( (defined($Apache::lonhomework::parsing_a_problem) |
| defined($Apache::lonhomework::parsing_a_task)) { |
|| defined($Apache::lonhomework::parsing_a_task)) |
| |
&& |
| |
($symbparm eq &symbread()) ) { |
| return $Apache::lonhomework::history{$qualifierrest}; |
return $Apache::lonhomework::history{$qualifierrest}; |
| } else { |
} else { |
| my %restored; |
my %restored; |
|
Line 4909 sub metadata_generate_part0 {
|
Line 5055 sub metadata_generate_part0 {
|
| '.type'}; |
'.type'}; |
| my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. |
my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. |
| '.display'}; |
'.display'}; |
| my $expr='\\[Part: '.$allnames{$name}.'\\]'; |
my $expr='[Part: '.$allnames{$name}.']'; |
| $olddis=~s/\Q$expr\E/\[Part: 0\]/; |
$olddis=~s/\Q$expr\E/\[Part: 0\]/; |
| $$metacache{"$key.display"}=$olddis; |
$$metacache{"$key.display"}=$olddis; |
| } |
} |
|
Line 5014 sub symbverify {
|
Line 5160 sub symbverify {
|
| if ($ids) { |
if ($ids) { |
| # ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
| foreach (split(/\,/,$ids)) { |
foreach (split(/\,/,$ids)) { |
| my ($mapid,$resid)=split(/\./,$_); |
my ($mapid,$resid)=split(/\./,$_); |
| if ( |
if ( |
| &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
| eq $symb) { |
eq $symb) { |
|
Line 5648 sub filelocation {
|
Line 5794 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=~m:^/home/[^/]*/public_html/:) { |
| |
# is a correct contruction space reference |
| |
$location = $file; |
| } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
| my ($udom,$uname,$filename)= |
my ($udom,$uname,$filename)= |
| ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); |
($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); |
|
Line 5680 sub filelocation {
|
Line 5829 sub filelocation {
|
| sub hreflocation { |
sub hreflocation { |
| my ($dir,$file)=@_; |
my ($dir,$file)=@_; |
| unless (($file=~m-^http://-i) || ($file=~m-^/-)) { |
unless (($file=~m-^http://-i) || ($file=~m-^/-)) { |
| my $finalpath=filelocation($dir,$file); |
$file=filelocation($dir,$file); |
| $finalpath=~s-^/home/httpd/html--; |
} |
| $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-; |
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { |
| return $finalpath; |
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--; |
| } elsif ($file=~m-^/home-) { |
} elsif ($file=~m-/home/(\w+)/public_html/-) { |
| $file=~s-^/home/httpd/html--; |
|
| $file=~s-^/home/(\w+)/public_html/-/~$1/-; |
$file=~s-^/home/(\w+)/public_html/-/~$1/-; |
| return $file; |
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { |
| |
$file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/ |
| |
-/uploaded/$1/$2/-x; |
| } |
} |
| return $file; |
return $file; |
| } |
} |
|
Line 5889 BEGIN {
|
Line 6039 BEGIN {
|
| |
|
| sub get_iphost { |
sub get_iphost { |
| if (%iphost) { return %iphost; } |
if (%iphost) { return %iphost; } |
| |
my %name_to_ip; |
| foreach my $id (keys(%hostname)) { |
foreach my $id (keys(%hostname)) { |
| my $name=$hostname{$id}; |
my $name=$hostname{$id}; |
| my $ip = gethostbyname($name); |
my $ip; |
| if (!$ip || length($ip) ne 4) { |
if (!exists($name_to_ip{$name})) { |
| &logthis("Skipping host $id name $name no IP found\n"); |
$ip = gethostbyname($name); |
| next; |
if (!$ip || length($ip) ne 4) { |
| |
&logthis("Skipping host $id name $name no IP found\n"); |
| |
next; |
| |
} |
| |
$ip=inet_ntoa($ip); |
| |
$name_to_ip{$name} = $ip; |
| |
} else { |
| |
$ip = $name_to_ip{$name}; |
| } |
} |
| $ip=inet_ntoa($ip); |
|
| push(@{$iphost{$ip}},$id); |
push(@{$iphost{$ip}},$id); |
| } |
} |
| return %iphost; |
return %iphost; |
|
Line 5971 $processmarker='_'.time.'_'.$perlvar{'lo
|
Line 6128 $processmarker='_'.time.'_'.$perlvar{'lo
|
| $dumpcount=0; |
$dumpcount=0; |
| |
|
| &logtouch(); |
&logtouch(); |
| &logthis('<font color=yellow>INFO: Read configuration</font>'); |
&logthis('<font color="yellow">INFO: Read configuration</font>'); |
| $readit=1; |
$readit=1; |
| { |
{ |
| use integer; |
use integer; |
|
Line 6798 userspace, probably shouldn't be called
|
Line 6955 userspace, probably shouldn't be called
|
| |
|
| docuname: username or courseid of destination for the file |
docuname: username or courseid of destination for the file |
| docudom: domain of user/course of destination for the file |
docudom: domain of user/course of destination for the file |
| docuhome: loncapa id of the library server that is getting the file |
|
| formname: same as for userfileupload() |
formname: same as for userfileupload() |
| fname: filename (inculding subdirectories) for the file |
fname: filename (inculding subdirectories) for the file |
| |
|
![[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