version 1.621, 2005/04/07 08:15:41
|
version 1.648, 2005/07/26 13:30:34
|
Line 47 use IO::Socket;
|
Line 47 use IO::Socket;
|
use GDBM_File; |
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
use HTML::LCParser; |
use HTML::LCParser; |
|
use HTML::Parser; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
use Apache::lonlocal; |
use Apache::lonlocal; |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
Line 827 sub getsection {
|
Line 828 sub getsection {
|
} |
} |
|
|
sub save_cache { |
sub save_cache { |
|
my ($r)=@_; |
|
if (! $r->is_initial_req()) { return DECLINED; } |
&purge_remembered(); |
&purge_remembered(); |
undef(%env); |
undef(%env); |
|
return OK; |
} |
} |
|
|
my $to_remember=-1; |
my $to_remember=-1; |
Line 875 sub do_cache_new {
|
Line 879 sub do_cache_new {
|
if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
$setvalue='__undef__'; |
$setvalue='__undef__'; |
} |
} |
|
if (!defined($time) ) { |
|
$time=600; |
|
} |
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
$memcache->set($id,$setvalue,$time); |
$memcache->set($id,$setvalue,$time); |
# need to make a copy of $value |
# need to make a copy of $value |
Line 1125 sub allowuploaded {
|
Line 1132 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. |
# path to file, source of file, instruction to parse file for objects, |
|
# ref to hash for embedded objects, |
|
# ref to hash for codebase of java objects. |
|
# |
# output: url to file (if action was uploaddoc), |
# output: url to file (if action was uploaddoc), |
# ok if successful, or diagnostic message otherwise (if action was propagate or copy) |
# ok if successful, or diagnostic message otherwise (if action was propagate or copy) |
# |
# |
Line 1149 sub allowuploaded {
|
Line 1159 sub allowuploaded {
|
# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file |
# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file |
# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file |
# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file |
# in course's home server. |
# in course's home server. |
|
# |
|
|
sub process_coursefile { |
sub process_coursefile { |
my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_; |
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 $fetchresult = ''; |
my $fpath = ''; |
my $fpath = ''; |
my $fname = $file; |
my $fname = $file; |
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; |
my $filepath = &build_filepath($fpath); |
unless ($fpath eq '') { |
|
my @parts=split('/',$fpath); |
|
foreach my $part (@parts) { |
|
$filepath.= '/'.$part; |
|
if ((-e $filepath)!=1) { |
|
mkdir($filepath,0777); |
|
} |
|
} |
|
} |
|
if ($action eq 'copy') { |
if ($action eq 'copy') { |
if ($source eq '') { |
if ($source eq '') { |
$fetchresult = 'no source file'; |
$fetchresult = 'no source file'; |
Line 1181 sub process_coursefile {
|
Line 1183 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); |
print $fh $env{'form.'.$source}; |
print $fh $env{'form.'.$source}; |
close($fh); |
close($fh); |
|
if ($parser eq 'parse') { |
|
my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase); |
|
unless ($parse_result eq 'ok') { |
|
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
|
} |
|
} |
$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; |
} |
} |
|
|
|
sub build_filepath { |
|
my ($fpath) = @_; |
|
my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; |
|
unless ($fpath eq '') { |
|
my @parts=split('/',$fpath); |
|
foreach my $part (@parts) { |
|
$filepath.= '/'.$part; |
|
if ((-e $filepath)!=1) { |
|
mkdir($filepath,0777); |
|
} |
|
} |
|
} |
|
return $filepath; |
|
} |
|
|
|
sub store_edited_file { |
|
my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_; |
|
my $file = $primary_url; |
|
$file =~ s#^/uploaded/$docudom/$docuname/##; |
|
my $fpath = ''; |
|
my $fname = $file; |
|
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
|
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
|
my $filepath = &build_filepath($fpath); |
|
open(my $fh,'>'.$filepath.'/'.$fname); |
|
print $fh $content; |
|
close($fh); |
|
my $home=&homeserver($docuname,$docudom); |
|
$$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
|
$home); |
|
if ($$fetchresult eq 'ok') { |
|
return '/uploaded/'.$fpath.'/'.$fname; |
|
} else { |
|
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
|
' to host '.$home.': '.$$fetchresult); |
|
return '/adm/notfound.html'; |
|
} |
|
} |
|
|
sub clean_filename { |
sub clean_filename { |
my ($fname)=@_; |
my ($fname)=@_; |
# Replace Windows backslashes by forward slashes |
# Replace Windows backslashes by forward slashes |
Line 1227 sub clean_filename {
|
Line 1274 sub clean_filename {
|
|
|
|
|
sub userfileupload { |
sub userfileupload { |
my ($formname,$coursedoc,$subdir)=@_; |
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_; |
if (!defined($subdir)) { $subdir='unknown'; } |
if (!defined($subdir)) { $subdir='unknown'; } |
my $fname=$env{'form.'.$formname.'.filename'}; |
my $fname=$env{'form.'.$formname.'.filename'}; |
$fname=&clean_filename($fname); |
$fname=&clean_filename($fname); |
Line 1251 sub userfileupload {
|
Line 1298 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); |
$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); |
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); |
$fname,$parser,$allfiles,$codebase); |
} |
} |
} |
} |
|
|
sub finishuserfileupload { |
sub finishuserfileupload { |
my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; |
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 1297 sub finishuserfileupload {
|
Line 1344 sub finishuserfileupload {
|
print FH $env{'form.'.$formname}; |
print FH $env{'form.'.$formname}; |
close(FH); |
close(FH); |
} |
} |
|
if ($parser eq 'parse') { |
|
my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, |
|
$codebase); |
|
unless ($parse_result eq 'ok') { |
|
&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 1311 sub finishuserfileupload {
|
Line 1367 sub finishuserfileupload {
|
} |
} |
} |
} |
|
|
|
sub extract_embedded_items { |
|
my ($filepath,$file,$allfiles,$codebase,$content) = @_; |
|
my @state = (); |
|
my %javafiles = ( |
|
codebase => '', |
|
code => '', |
|
archive => '' |
|
); |
|
my %mediafiles = ( |
|
src => '', |
|
movie => '', |
|
); |
|
my $p; |
|
if ($content) { |
|
$p = HTML::LCParser->new($content); |
|
} else { |
|
$p = HTML::LCParser->new($filepath.'/'.$file); |
|
} |
|
while (my $t=$p->get_token()) { |
|
if ($t->[0] eq 'S') { |
|
my ($tagname, $attr) = ($t->[1],$t->[2]); |
|
push (@state, $tagname); |
|
if (lc($tagname) eq 'allow') { |
|
&add_filetype($allfiles,$attr->{'src'},'src'); |
|
} |
|
if (lc($tagname) eq 'img') { |
|
&add_filetype($allfiles,$attr->{'src'},'src'); |
|
} |
|
if (lc($tagname) eq 'script') { |
|
if ($attr->{'archive'} =~ /\.jar$/i) { |
|
&add_filetype($allfiles,$attr->{'archive'},'archive'); |
|
} else { |
|
&add_filetype($allfiles,$attr->{'src'},'src'); |
|
} |
|
} |
|
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)); |
|
} |
|
} |
|
|
sub removeuploadedurl { |
sub removeuploadedurl { |
my ($url)=@_; |
my ($url)=@_; |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
Line 1614 sub courseidput {
|
Line 1778 sub courseidput {
|
} |
} |
|
|
sub courseiddump { |
sub courseiddump { |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_; |
my %returnhash=(); |
my %returnhash=(); |
unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
Line 1623 sub courseiddump {
|
Line 1787 sub courseiddump {
|
foreach ( |
foreach ( |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
$sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
&escape($instcodefilter).':'.&escape($ownerfilter), |
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter), |
$tryserver))) { |
$tryserver))) { |
my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
if (($key) && ($value)) { |
if (($key) && ($value)) { |
Line 2558 sub convert_dump_to_currentdump{
|
Line 2722 sub convert_dump_to_currentdump{
|
return \%returnhash; |
return \%returnhash; |
} |
} |
|
|
|
# ------------------------------------------------------ critical inc interface |
|
|
|
sub cinc { |
|
return &inc(@_,'critical'); |
|
} |
|
|
# --------------------------------------------------------------- inc interface |
# --------------------------------------------------------------- inc interface |
|
|
sub inc { |
sub inc { |
my ($namespace,$store,$udomain,$uname) = @_; |
my ($namespace,$store,$udomain,$uname,$critical) = @_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
Line 2579 sub inc {
|
Line 2749 sub inc {
|
} |
} |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); |
if ($critical) { |
|
return &critical("inc:$udomain:$uname:$namespace:$items",$uhome); |
|
} else { |
|
return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); |
|
} |
} |
} |
|
|
# --------------------------------------------------------------- put interface |
# --------------------------------------------------------------- put interface |
Line 2597 sub put {
|
Line 2771 sub put {
|
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
} |
} |
|
|
# ---------------------------------------------------------- putstore interface |
# ------------------------------------------------------------ newput interface |
|
|
|
sub newput { |
|
my ($namespace,$storehash,$udomain,$uname)=@_; |
|
if (!$udomain) { $udomain=$env{'user.domain'}; } |
|
if (!$uname) { $uname=$env{'user.name'}; } |
|
my $uhome=&homeserver($uname,$udomain); |
|
my $items=''; |
|
foreach my $key (keys(%$storehash)) { |
|
$items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
|
} |
|
$items=~s/\&$//; |
|
return &reply("newput:$udomain:$uname:$namespace:$items",$uhome); |
|
} |
|
|
|
# --------------------------------------------------------- putstore interface |
|
|
sub putstore { |
sub putstore { |
my ($namespace,$storehash,$udomain,$uname)=@_; |
my ($namespace,$storehash,$udomain,$uname)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
Line 2712 sub allowed {
|
Line 2901 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 2799 sub allowed {
|
Line 2988 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 3673 sub createcourse {
|
Line 3871 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 3740 sub mark_as_readonly {
|
Line 3938 sub mark_as_readonly {
|
my %current_permissions = &dump('file_permissions',$domain,$user); |
my %current_permissions = &dump('file_permissions',$domain,$user); |
my ($tmp)=keys(%current_permissions); |
my ($tmp)=keys(%current_permissions); |
if ($tmp=~/^error:/) { undef(%current_permissions); } |
if ($tmp=~/^error:/) { undef(%current_permissions); } |
|
|
foreach my $file (@{$files}) { |
foreach my $file (@{$files}) { |
push(@{$current_permissions{$file}},$what); |
push(@{$current_permissions{$file}},$what); |
} |
} |
Line 3819 sub files_not_in_path {
|
Line 4016 sub files_not_in_path {
|
|
|
#--------------------------------------------------------------Get Marked as Read Only |
#--------------------------------------------------------------Get Marked as Read Only |
|
|
|
|
sub get_marked_as_readonly { |
sub get_marked_as_readonly { |
my ($domain,$user,$what) = @_; |
my ($domain,$user,$what) = @_; |
my %current_permissions = &dump('file_permissions',$domain,$user); |
my %current_permissions = &dump('file_permissions',$domain,$user); |
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; |
my @readonly_files; |
|
my $cmp1=$what; |
|
if (ref($what)) { $cmp1=join('',@{$what}) }; |
while (my ($file_name,$value) = each(%current_permissions)) { |
while (my ($file_name,$value) = each(%current_permissions)) { |
if (ref($value) eq "ARRAY"){ |
if (ref($value) eq "ARRAY"){ |
foreach my $stored_what (@{$value}) { |
foreach my $stored_what (@{$value}) { |
if ($stored_what eq $what) { |
my $cmp2=$stored_what; |
|
if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) }; |
|
if ($cmp1 eq $cmp2) { |
push(@readonly_files, $file_name); |
push(@readonly_files, $file_name); |
} elsif (!defined($what)) { |
} elsif (!defined($what)) { |
push(@readonly_files, $file_name); |
push(@readonly_files, $file_name); |
Line 3864 sub get_marked_as_readonly_hash {
|
Line 4065 sub get_marked_as_readonly_hash {
|
# ------------------------------------------------------------ Unmark as Read Only |
# ------------------------------------------------------------ Unmark as Read Only |
|
|
sub unmark_as_readonly { |
sub unmark_as_readonly { |
# unmarks all files locked by $what |
# unmarks $file_name (if $file_name is defined), or all files locked by $what |
# for portfolio submissions, $what contains $crsid and $symb |
# for portfolio submissions, $what contains [$symb,$crsid] |
my ($domain,$user,$what) = @_; |
my ($domain,$user,$what,$file_name) = @_; |
|
my $symb_crs = $what; |
|
if (ref($what)) { $symb_crs=join('',@$what); } |
my %current_permissions = &dump('file_permissions',$domain,$user); |
my %current_permissions = &dump('file_permissions',$domain,$user); |
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}; |
my $current_locks = $current_permissions{$file}; |
Line 3878 sub unmark_as_readonly {
|
Line 4080 sub unmark_as_readonly {
|
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}) { |
unless ($locker eq $what) { |
my $compare=$locker; |
|
if (ref($locker)) { $compare=join('',@{$locker}) }; |
|
if ($compare eq $symb_crs) { |
|
if (defined($file_name) && ($file_name ne $file)) { |
|
push(@new_locks, $what); |
|
} |
|
} else { |
push(@new_locks, $what); |
push(@new_locks, $what); |
} |
} |
} |
} |
Line 4082 sub devalidatecourseresdata {
|
Line 4290 sub devalidatecourseresdata {
|
|
|
# --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
|
|
sub courseresdata { |
sub get_courseresdata { |
my ($coursenum,$coursedomain,@which)=@_; |
my ($coursenum,$coursedomain)=@_; |
my $coursehom=&homeserver($coursenum,$coursedomain); |
my $coursehom=&homeserver($coursenum,$coursedomain); |
my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
my ($result,$cached)=&is_cached_new('courseres',$hashid); |
my ($result,$cached)=&is_cached_new('courseres',$hashid); |
|
my %dumpreply; |
unless (defined($cached)) { |
unless (defined($cached)) { |
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
%dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
$result=\%dumpreply; |
$result=\%dumpreply; |
my ($tmp) = keys(%dumpreply); |
my ($tmp) = keys(%dumpreply); |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
Line 4100 sub courseresdata {
|
Line 4309 sub courseresdata {
|
&do_cache_new('courseres',$hashid,$result,600); |
&do_cache_new('courseres',$hashid,$result,600); |
} |
} |
} |
} |
|
return $result; |
|
} |
|
|
|
sub devalidateuserresdata { |
|
my ($uname,$udom)=@_; |
|
my $hashid="$udom:$uname"; |
|
&devalidate_cache_new('userres',$hashid); |
|
} |
|
|
|
sub get_userresdata { |
|
my ($uname,$udom)=@_; |
|
#most student don\'t have any data set, check if there is some data |
|
if (&EXT_cache_status($udom,$uname)) { return undef; } |
|
|
|
my $hashid="$udom:$uname"; |
|
my ($result,$cached)=&is_cached_new('userres',$hashid); |
|
if (!defined($cached)) { |
|
my %resourcedata=&dump('resourcedata',$udom,$uname); |
|
$result=\%resourcedata; |
|
&do_cache_new('userres',$hashid,$result,600); |
|
} |
|
my ($tmp)=keys(%$result); |
|
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
|
return $result; |
|
} |
|
#error 2 occurs when the .db doesn't exist |
|
if ($tmp!~/error: 2 /) { |
|
&logthis("<font color=blue>WARNING:". |
|
" Trying to get resource data for ". |
|
$uname." at ".$udom.": ". |
|
$tmp."</font>"); |
|
} elsif ($tmp=~/error: 2 /) { |
|
#&EXT_cache_set($udom,$uname); |
|
&do_cache_new('userres',$hashid,undef,600); |
|
undef($tmp); # not really an error so don't send it back |
|
} |
|
return $tmp; |
|
} |
|
|
|
sub resdata { |
|
my ($name,$domain,$type,@which)=@_; |
|
my $result; |
|
if ($type eq 'course') { |
|
$result=&get_courseresdata($name,$domain); |
|
} elsif ($type eq 'user') { |
|
$result=&get_userresdata($name,$domain); |
|
} |
|
if (!ref($result)) { return $result; } |
foreach my $item (@which) { |
foreach my $item (@which) { |
if (defined($result->{$item})) { |
if (defined($result->{$item})) { |
return $result->{$item}; |
return $result->{$item}; |
Line 4130 sub EXT_cache_status {
|
Line 4387 sub EXT_cache_status {
|
sub EXT_cache_set { |
sub EXT_cache_set { |
my ($target_domain,$target_user) = @_; |
my ($target_domain,$target_user) = @_; |
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
&appenv($cachename => time); |
#&appenv($cachename => time); |
} |
} |
|
|
# --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
Line 4285 sub EXT {
|
Line 4542 sub EXT {
|
$courselevelm=$courseid.'.'.$mapparm; |
$courselevelm=$courseid.'.'.$mapparm; |
|
|
# ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
#most student don\'t have any data set, check if there is some data |
|
if (! &EXT_cache_status($udom,$uname)) { |
my $userreply=&resdata($uname,$udom,'user', |
my $hashid="$udom:$uname"; |
($courselevelr,$courselevelm, |
my ($result,$cached)=&is_cached_new('userres',$hashid); |
$courselevel)); |
if (!defined($cached)) { |
|
my %resourcedata=&dump('resourcedata',$udom,$uname); |
if (defined($userreply)) { return $userreply; } |
$result=\%resourcedata; |
|
&do_cache_new('userres',$hashid,$result); |
|
} |
|
my ($tmp)=keys(%$result); |
|
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
|
if ($$result{$courselevelr}) { |
|
return $$result{$courselevelr}; } |
|
if ($$result{$courselevelm}) { |
|
return $$result{$courselevelm}; } |
|
if ($$result{$courselevel}) { |
|
return $$result{$courselevel}; } |
|
} else { |
|
#error 2 occurs when the .db doesn't exist |
|
if ($tmp!~/error: 2 /) { |
|
&logthis("<font color=blue>WARNING:". |
|
" Trying to get resource data for ". |
|
$uname." at ".$udom.": ". |
|
$tmp."</font>"); |
|
} elsif ($tmp=~/error: 2 /) { |
|
&EXT_cache_set($udom,$uname); |
|
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
|
return $tmp; |
|
} |
|
} |
|
} |
|
|
|
# ------------------------------------------------ second, check some of course |
# ------------------------------------------------ second, check some of course |
|
|
my $coursereply=&courseresdata($env{'course.'.$courseid.'.num'}, |
my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
$env{'course.'.$courseid.'.domain'}, |
$env{'course.'.$courseid.'.domain'}, |
($seclevelr,$seclevelm,$seclevel, |
'course', |
$courselevelr)); |
($seclevelr,$seclevelm,$seclevel, |
|
$courselevelr)); |
if (defined($coursereply)) { return $coursereply; } |
if (defined($coursereply)) { return $coursereply; } |
|
|
# ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
Line 4354 sub EXT {
|
Line 4587 sub EXT {
|
# ---------------------------------------------- fourth, look in rest pf course |
# ---------------------------------------------- fourth, look in rest pf course |
if ($symbparm && defined($courseid) && |
if ($symbparm && defined($courseid) && |
$courseid eq $env{'request.course.id'}) { |
$courseid eq $env{'request.course.id'}) { |
my $coursereply=&courseresdata($env{'course.'.$courseid.'.num'}, |
my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
$env{'course.'.$courseid.'.domain'}, |
$env{'course.'.$courseid.'.domain'}, |
($courselevelm,$courselevel)); |
'course', |
|
($courselevelm,$courselevel)); |
if (defined($coursereply)) { return $coursereply; } |
if (defined($coursereply)) { return $coursereply; } |
} |
} |
# ------------------------------------------------------------------ Cascade up |
# ------------------------------------------------------------------ Cascade up |
Line 4584 sub metadata {
|
Line 4818 sub metadata {
|
} |
} |
my ($extension) = ($uri =~ /\.(\w+)$/); |
my ($extension) = ($uri =~ /\.(\w+)$/); |
foreach my $key (sort(keys(%packagetab))) { |
foreach my $key (sort(keys(%packagetab))) { |
#&logthis("extsion1 $extension $key !!"); |
|
#no specific packages #how's our extension |
#no specific packages #how's our extension |
if ($key!~/^extension_\Q$extension\E&/) { next; } |
if ($key!~/^extension_\Q$extension\E&/) { next; } |
&metadata_create_package_def($uri,$key,'extension_'.$extension, |
&metadata_create_package_def($uri,$key,'extension_'.$extension, |
Line 4620 sub metadata {
|
Line 4853 sub metadata {
|
$metaentry{':keys'}=join(',',keys %metathesekeys); |
$metaentry{':keys'}=join(',',keys %metathesekeys); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
&do_cache_new('meta',$uri,\%metaentry); |
&do_cache_new('meta',$uri,\%metaentry,60*60*24); |
# this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
} |
} |
return $metaentry{':'.$what}; |
return $metaentry{':'.$what}; |
Line 4672 sub metadata_generate_part0 {
|
Line 4905 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 4777 sub symbverify {
|
Line 5010 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 4916 sub symbread {
|
Line 5149 sub symbread {
|
if ($#possibilities==0) { |
if ($#possibilities==0) { |
# ----------------------------------------------- There is only one possibility |
# ----------------------------------------------- There is only one possibility |
my ($mapid,$resid)=split(/\./,$ids); |
my ($mapid,$resid)=split(/\./,$ids); |
$syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; |
$syval=&encode_symb($bighash{'map_id_'.$mapid}, |
|
$resid,$thisfn); |
} elsif (!$donotrecurse) { |
} elsif (!$donotrecurse) { |
# ------------------------------------------ There is more than one possibility |
# ------------------------------------------ There is more than one possibility |
my $realpossible=0; |
my $realpossible=0; |
Line 4926 sub symbread {
|
Line 5160 sub symbread {
|
my ($mapid,$resid)=split(/\./,$_); |
my ($mapid,$resid)=split(/\./,$_); |
if ($bighash{'map_type_'.$mapid} ne 'page') { |
if ($bighash{'map_type_'.$mapid} ne 'page') { |
$realpossible++; |
$realpossible++; |
$syval=declutter($bighash{'map_id_'.$mapid}). |
$syval=&encode_symb($bighash{'map_id_'.$mapid}, |
'___'.$resid; |
$resid,$thisfn); |
} |
} |
} |
} |
} |
} |
Line 4941 sub symbread {
|
Line 5175 sub symbread {
|
} |
} |
if ($syval) { |
if ($syval) { |
return $env{$cache_str}=$syval; |
return $env{$cache_str}=$syval; |
#return $env{$cache_str}=&symbclean($syval.'___'.$thisfn); |
|
} |
} |
} |
} |
&appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
Line 6136 revokecustomrole($udom,$uname,$url,$role
|
Line 6369 revokecustomrole($udom,$uname,$url,$role
|
|
|
=item * |
=item * |
|
|
coursedescription($courseid) : course description |
coursedescription($courseid) : returns a hash of information about the |
|
specified course id, including all environment settings for the |
|
course, the description of the course will be in the hash under the |
|
key 'description' |
|
|
=item * |
=item * |
|
|
courseresdata($coursenum,$coursedomain,@which) : request for current |
resdata($name,$domain,$type,@which) : request for current parameter |
parameter setting for a specific course, @what should be a list of |
setting for a specific $type, where $type is either 'course' or 'user', |
parameters to ask about. This routine caches answers for 5 minutes. |
@what should be a list of parameters to ask about. This routine caches |
|
answers for 5 minutes. |
|
|
=back |
=back |
|
|
Line 6557 userspace, probably shouldn't be called
|
Line 6794 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 |
|
|