version 1.134, 2001/07/27 20:17:14
|
version 1.146, 2001/08/09 16:43:06
|
Line 121
|
Line 121
|
# 5/26,5/28 Gerd Kortemeyer |
# 5/26,5/28 Gerd Kortemeyer |
# 5/30 H. K. Ng |
# 5/30 H. K. Ng |
# 6/1 Gerd Kortemeyer |
# 6/1 Gerd Kortemeyer |
# |
# July Guy Albertelli |
|
# 8/4,8/7,8/8,8/9 Gerd Kortemeyer |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
Line 130 use Apache::File;
|
Line 131 use Apache::File;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Headers; |
use HTTP::Headers; |
use vars |
use vars |
qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache); |
qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab); |
use IO::Socket; |
use IO::Socket; |
use GDBM_File; |
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
Line 895 sub rolesinit {
|
Line 896 sub rolesinit {
|
my $author=0; |
my $author=0; |
map { |
map { |
%thesepriv=(); |
%thesepriv=(); |
if ($_!~/^st/) { $adv=1; } |
if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } |
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } |
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } |
map { |
map { |
if ($_ ne '') { |
if ($_ ne '') { |
Line 1734 sub EXT {
|
Line 1735 sub EXT {
|
$spacequalifierrest}; |
$spacequalifierrest}; |
} elsif ($realm eq 'resource') { |
} elsif ($realm eq 'resource') { |
if ($ENV{'request.course.id'}) { |
if ($ENV{'request.course.id'}) { |
|
|
|
# print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
|
|
|
|
# ----------------------------------------------------- Cascading lookup scheme |
# ----------------------------------------------------- Cascading lookup scheme |
my $symbp=&symbread(); |
my $symbp=&symbread(); |
my $mapp=(split(/\_\_\_/,$symbp))[0]; |
my $mapp=(split(/\_\_\_/,$symbp))[0]; |
Line 1823 sub EXT {
|
Line 1828 sub EXT {
|
'parameter_'.$spacequalifierrest); |
'parameter_'.$spacequalifierrest); |
if ($metadata) { return $metadata; } |
if ($metadata) { return $metadata; } |
|
|
|
# ------------------------------------------------------------------ Cascade up |
|
|
|
unless ($space eq '0') { |
|
my ($part,$id)=split(/\_/,$space); |
|
if ($id) { |
|
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest); |
|
if ($partgeneral) { return $partgeneral; } |
|
} else { |
|
my $resourcegeneral=&EXT('resource.0.'.$qualifierrest); |
|
if ($resourcegeneral) { return $resourcegeneral; } |
|
} |
|
} |
|
|
# ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
} elsif ($realm eq 'environment') { |
} elsif ($realm eq 'environment') { |
# ----------------------------------------------------------------- environment |
# ----------------------------------------------------------------- environment |
Line 1845 sub metadata {
|
Line 1863 sub metadata {
|
my $filename=$uri; |
my $filename=$uri; |
$uri=~s/\.meta$//; |
$uri=~s/\.meta$//; |
unless ($metacache{$uri.':keys'}) { |
unless ($metacache{$uri.':keys'}) { |
|
my %metathesekeys=(); |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); |
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); |
my $parser=HTML::TokeParser->new(\$metastring); |
my $parser=HTML::TokeParser->new(\$metastring); |
my $token; |
my $token; |
|
undef %metathesekeys; |
while ($token=$parser->get_token) { |
while ($token=$parser->get_token) { |
if ($token->[0] eq 'S') { |
if ($token->[0] eq 'S') { |
|
if (defined($token->[2]->{'package'})) { |
|
my $package=$token->[2]->{'package'}; |
|
my $keyroot=''; |
|
if (defined($token->[2]->{'part'})) { |
|
$keyroot.='_'.$token->[2]->{'part'}; |
|
} |
|
if (defined($token->[2]->{'id'})) { |
|
$keyroot.='_'.$token->[2]->{'id'}; |
|
} |
|
if ($metacache{$uri.':packages'}) { |
|
$metacache{$uri.':packages'}.=','.$package.$keyroot; |
|
} else { |
|
$metacache{$uri.':packages'}=$package.$keyroot; |
|
} |
|
map { |
|
if ($_=~/^$package\&/) { |
|
my ($pack,$name,$subp)=split(/\&/,$_); |
|
my $value=$packagetab{$_}; |
|
my $part=$keyroot; |
|
$part=~s/^\_//; |
|
if ($subp eq 'display') { |
|
$value.=' [Part: '.$part.']'; |
|
} |
|
my $unikey='parameter'.$keyroot.'_'.$name; |
|
$metathesekeys{$unikey}=1; |
|
$metacache{$uri.':'.$unikey.'.part'}=$part; |
|
unless |
|
(defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
|
$metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
|
} |
|
} |
|
} keys %packagetab; |
|
} else { |
my $entry=$token->[1]; |
my $entry=$token->[1]; |
my $unikey=$entry; |
my $unikey=$entry; |
if (defined($token->[2]->{'part'})) { |
if (defined($token->[2]->{'part'})) { |
$unikey.='_'.$token->[2]->{'part'}; |
$unikey.='_'.$token->[2]->{'part'}; |
} |
} |
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
$unikey.='_'.$token->[2]->{'name'}; |
$unikey.='_'.$token->[2]->{'name'}; |
} |
} |
if ($metacache{$uri.':keys'}) { |
$metathesekeys{$unikey}=1; |
$metacache{$uri.':keys'}.=','.$unikey; |
|
} else { |
|
$metacache{$uri.':keys'}=$unikey; |
|
} |
|
map { |
map { |
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
} @{$token->[3]}; |
} @{$token->[3]}; |
Line 1872 sub metadata {
|
Line 1924 sub metadata {
|
) { $metacache{$uri.':'.$unikey}= |
) { $metacache{$uri.':'.$unikey}= |
$metacache{$uri.':'.$unikey.'.default'}; |
$metacache{$uri.':'.$unikey.'.default'}; |
} |
} |
} |
} |
|
} |
} |
} |
|
$metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
} |
} |
return $metacache{$uri.':'.$what}; |
return $metacache{$uri.':'.$what}; |
} |
} |
Line 2154 if ($readit ne 'done') {
|
Line 2208 if ($readit ne 'done') {
|
} |
} |
} |
} |
|
|
|
# ---------------------------------------------------------- Read package table |
|
{ |
|
my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); |
|
|
|
while (my $configline=<$config>) { |
|
chomp($configline); |
|
my ($short,$plain)=split(/:/,$configline); |
|
my ($pack,$name)=split(/\&/,$short); |
|
if ($plain ne '') { |
|
$packagetab{$pack.'&'.$name.'&name'}=$name; |
|
$packagetab{$short}=$plain; |
|
} |
|
} |
|
} |
|
|
# ------------------------------------------------------------- Read file types |
# ------------------------------------------------------------- Read file types |
{ |
{ |
my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); |
my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); |