version 1.638, 2005/06/13 20:23:54
|
version 1.651.2.5, 2005/09/26 22:16:58
|
Line 1302 sub userfileupload {
|
Line 1302 sub userfileupload {
|
if ($coursedoc) { |
if ($coursedoc) { |
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
if ($env{'form.folder'} =~ m/^default/) { |
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
return &finishuserfileupload($docuname,$docudom, |
return &finishuserfileupload($docuname,$docudom, |
$formname,$fname,$parser,$allfiles, |
$formname,$fname,$parser,$allfiles, |
$codebase); |
$codebase); |
Line 1368 sub finishuserfileupload {
|
Line 1368 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 1379 sub extract_embedded_items {
|
Line 1379 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'); |
} |
} else { |
} |
&add_filetype($allfiles,$attr->{'src'},'src'); |
if (lc($state[-2]) eq 'object') { |
} |
if (lc($tagname) eq 'param') { |
} |
my $name = lc($attr->{'name'}); |
if (lc($tagname) eq 'link') { |
foreach my $item (keys (%mediafiles)) { |
if (lc($attr->{'rel'}) eq 'stylesheet') { |
if ($name eq $item) { |
&add_filetype($allfiles,$attr->{'href'},'href'); |
if (exists($$allfiles{$attr->{'value'}})) { |
} |
unless(grep/^value$/,@{$$allfiles{$attr->{'value'}}}) { |
} |
push(@{$$allfiles{$attr->{'value'}}},&escape('value')); |
if (lc($tagname) eq 'object' || |
} |
(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) { |
} else { |
foreach my $item (keys(%javafiles)) { |
@{$$allfiles{$attr->{'value'}}} = (&escape('value')); |
$javafiles{$item} = ''; |
} |
} |
last; |
} |
} |
if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { |
} |
my $name = lc($attr->{'name'}); |
foreach my $item (keys (%javafiles)) { |
foreach my $item (keys(%javafiles)) { |
if ($name eq $item) { |
if ($name eq $item) { |
$javafiles{$item} = $attr->{'value'}; |
$javafiles{$item} = $attr->{'value'}; |
last; |
last; |
} |
} |
} |
} |
} |
foreach my $item (keys(%mediafiles)) { |
} |
if ($name eq $item) { |
if (lc($tagname) eq 'embed') { |
&add_filetype($allfiles, $attr->{'value'}, 'value'); |
unless (lc($state[-2]) eq 'object') { |
last; |
foreach my $item (keys (%javafiles)) { |
} |
$javafiles{$item} = ''; |
} |
} |
} |
} |
if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { |
foreach my $item (keys (%javafiles)) { |
foreach my $item (keys(%javafiles)) { |
if ($attr->{$item}) { |
if ($attr->{$item}) { |
$javafiles{$item} = $attr->{$item}; |
$javafiles{$item} = $attr->{$item}; |
last; |
last; |
} |
} |
} |
} |
foreach my $item (keys (%mediafiles)) { |
foreach my $item (keys(%mediafiles)) { |
if ($attr->{$item}) { |
if ($attr->{$item}) { |
if (exists($$allfiles{$attr->{$item}})) { |
&add_filetype($allfiles,$attr->{$item},$item); |
unless (grep/^$item$/,@{$$allfiles{$item}}) { |
last; |
push(@{$$allfiles{$attr->{$item}}},&escape($item)); |
} |
} |
} |
} else { |
} |
@{$$allfiles{$attr->{$item}}} = (&escape($item)); |
} elsif ($t->[0] eq 'E') { |
} |
my ($tagname) = ($t->[1]); |
last; |
if ($javafiles{'codebase'} ne '') { |
} |
$javafiles{'codebase'} .= '/'; |
} |
} |
} |
if (lc($tagname) eq 'applet' || |
}, "tagname, attr"], |
lc($tagname) eq 'object' || |
text_h => |
(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object') |
[sub { |
) { |
my ($text) = @_; |
foreach my $item (keys(%javafiles)) { |
}, "dtext"], |
if ($item ne 'codebase' && $javafiles{$item} ne '') { |
end_h => |
my $file=$javafiles{'codebase'}.$javafiles{$item}; |
[sub { |
&add_filetype($allfiles,$file,$item); |
my ($tagname) = @_; |
} |
unless ($javafiles{'codebase'} eq '') { |
} |
$javafiles{'codebase'} .= '/'; |
} |
} |
pop @state; |
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'; |
return 'ok'; |
} |
} |
|
|
sub extract_java_items { |
sub add_filetype { |
my ($javafiles,$allfiles,$codebase) = @_; |
my ($allfiles,$file,$type)=@_; |
foreach my $item (keys(%{$javafiles})) { |
if (exists($allfiles->{$file})) { |
if ($item ne 'codebase') { |
unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) { |
if ($$javafiles{$item} ne '') { |
push(@{$allfiles->{$file}}, &escape($type)); |
my $file=$javafiles->{'codebase'}.$javafiles->{$item}; |
} |
if (exists($allfiles->{$file})) { |
} else { |
unless (scalar(grep(/^$item$/, @{$allfiles->{$file}}))) { |
@{$allfiles->{$file}} = (&escape($type)); |
push(@{$allfiles->{$file}}, &escape($item)); |
|
} |
|
} else { |
|
@{$allfiles->{$file}} = (&escape($item)); |
|
$codebase->{$file} = $javafiles->{'codebase'}; |
|
} |
|
} |
|
} |
|
} |
} |
} |
} |
|
|
Line 1655 sub courseacclog {
|
Line 1636 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 1728 sub get_course_adv_roles {
|
Line 1709 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 2497 sub rolesinit {
|
Line 2482 sub rolesinit {
|
|
|
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 2920 sub allowed {
|
Line 2909 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 3007 sub allowed {
|
Line 2996 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 4084 sub unmark_as_readonly {
|
Line 4082 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 4433 sub EXT {
|
Line 4428 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 4863 sub metadata {
|
Line 4860 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,60*60*24); |
&do_cache_new('meta',$uri,\%metaentry,600); |
# 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 4915 sub metadata_generate_part0 {
|
Line 4912 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 5020 sub symbverify {
|
Line 5017 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 5654 sub filelocation {
|
Line 5651 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 5890 BEGIN {
|
Line 5890 BEGIN {
|
} |
} |
close($config); |
close($config); |
# FIXME: dev server don't want this, production servers _do_ want this |
# FIXME: dev server don't want this, production servers _do_ want this |
#&get_iphost(); |
&get_iphost(); |
} |
} |
|
|
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; |