version 1.320, 2003/01/28 00:09:57
|
version 1.338, 2003/03/14 02:26:12
|
Line 47
|
Line 47
|
# 09/01 Guy Albertelli |
# 09/01 Guy Albertelli |
# 09/01,10/01,11/01 Gerd Kortemeyer |
# 09/01,10/01,11/01 Gerd Kortemeyer |
# YEAR=2001 |
# YEAR=2001 |
# 02/27/01 Scott Harrison |
|
# 3/2 Gerd Kortemeyer |
# 3/2 Gerd Kortemeyer |
# 3/15,3/19 Scott Harrison |
|
# 3/19,3/20 Gerd Kortemeyer |
# 3/19,3/20 Gerd Kortemeyer |
# 3/22,3/27,4/2,4/16,4/17 Scott Harrison |
|
# 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 |
# July Guy Albertelli |
# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, |
# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, |
# 10/2 Gerd Kortemeyer |
# 10/2 Gerd Kortemeyer |
# 10/5,10/10,11/13,11/15 Scott Harrison |
|
# 11/17,11/20,11/22,11/29 Gerd Kortemeyer |
# 11/17,11/20,11/22,11/29 Gerd Kortemeyer |
# 12/5 Matthew Hall |
# 12/5 Matthew Hall |
# 12/5 Guy Albertelli |
# 12/5 Guy Albertelli |
# 12/6,12/7,12/12 Gerd Kortemeyer |
# 12/6,12/7,12/12 Gerd Kortemeyer |
# 12/18 Scott Harrison |
|
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer |
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer |
# YEAR=2002 |
# YEAR=2002 |
# 1/4,2/4,2/7 Gerd Kortemeyer |
# 1/4,2/4,2/7 Gerd Kortemeyer |
Line 81 qw(%perlvar %hostname %homecache %badSer
|
Line 76 qw(%perlvar %hostname %homecache %badSer
|
%libserv %pr %prp %metacache %packagetab %titlecache |
%libserv %pr %prp %metacache %packagetab %titlecache |
%courselogs %accesshash $processmarker $dumpcount |
%courselogs %accesshash $processmarker $dumpcount |
%coursedombuf %coursehombuf %courseresdatacache |
%coursedombuf %coursehombuf %courseresdatacache |
%domaindescription); |
%domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); |
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 734 sub subscribe {
|
Line 729 sub subscribe {
|
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
my $home=homeserver($uname,$udom); |
my $home=homeserver($uname,$udom); |
if ($home eq 'no_host') { |
if ($home eq 'no_host') { |
return 'not_found'; |
return 'not_found'; |
} |
} |
my $answer=reply("sub:$fname",$home); |
my $answer=reply("sub:$fname",$home); |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
Line 809 sub repcopy {
|
Line 804 sub repcopy {
|
} |
} |
} |
} |
|
|
|
# ------------------------------------------------ Get server side include body |
|
sub ssi_body { |
|
my $filelink=shift; |
|
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
|
&ssi($filelink)); |
|
$output=~s/^.*\<body[^\>]*\>//si; |
|
$output=~s/\<\/body\s*\>.*$//si; |
|
$output=~ |
|
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
|
return $output; |
|
} |
|
|
# --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
|
|
sub ssi { |
sub ssi { |
Line 832 sub ssi {
|
Line 839 sub ssi {
|
return $response->content; |
return $response->content; |
} |
} |
|
|
|
sub externalssi { |
|
my ($url)=@_; |
|
my $ua=new LWP::UserAgent; |
|
my $request=new HTTP::Request('GET',$url); |
|
my $response=$ua->request($request); |
|
return $response->content; |
|
} |
|
|
# ------- Add a token to a remote URI's query string to vouch for access rights |
# ------- Add a token to a remote URI's query string to vouch for access rights |
|
|
sub tokenwrapper { |
sub tokenwrapper { |
Line 1109 sub expirespread {
|
Line 1124 sub expirespread {
|
# ----------------------------------------------------- Devalidate Spreadsheets |
# ----------------------------------------------------- Devalidate Spreadsheets |
|
|
sub devalidate { |
sub devalidate { |
my $symb=shift; |
my ($symb,$uname,$udom)=@_; |
my $cid=$ENV{'request.course.id'}; |
my $cid=$ENV{'request.course.id'}; |
if ($cid) { |
if ($cid) { |
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; |
# delete the stored spreadsheets for |
|
# - the student level sheet of this user in course's homespace |
|
# - the assessment level sheet for this resource |
|
# for this user in user's homespace |
|
my $key=$uname.':'.$udom.':'; |
my $status= |
my $status= |
&del('nohist_calculatedsheets', |
&del('nohist_calculatedsheets', |
[$key.'studentcalc'], |
[$key.'studentcalc'], |
Line 1123 sub devalidate {
|
Line 1142 sub devalidate {
|
[$key.'assesscalc:'.$symb]); |
[$key.'assesscalc:'.$symb]); |
unless ($status eq 'ok ok') { |
unless ($status eq 'ok ok') { |
&logthis('Could not devalidate spreadsheet '. |
&logthis('Could not devalidate spreadsheet '. |
$ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. |
$uname.' at '.$udom.' for '. |
$symb.': '.$status); |
$symb.': '.$status); |
} |
} |
} |
} |
Line 1455 sub store {
|
Line 1474 sub store {
|
$symb=&symbclean($symb); |
$symb=&symbclean($symb); |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
|
|
&devalidate($symb); |
if (!$domain) { $domain=$ENV{'user.domain'}; } |
|
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
|
|
|
&devalidate($symb,$stuname,$domain); |
|
|
$symb=escape($symb); |
$symb=escape($symb); |
if (!$namespace) { |
if (!$namespace) { |
Line 1463 sub store {
|
Line 1485 sub store {
|
return ''; |
return ''; |
} |
} |
} |
} |
if (!$domain) { $domain=$ENV{'user.domain'}; } |
|
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
|
if (!$home) { $home=$ENV{'user.home'}; } |
if (!$home) { $home=$ENV{'user.home'}; } |
my $namevalue=''; |
my $namevalue=''; |
foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
Line 1486 sub cstore {
|
Line 1506 sub cstore {
|
$symb=&symbclean($symb); |
$symb=&symbclean($symb); |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
|
|
&devalidate($symb); |
if (!$domain) { $domain=$ENV{'user.domain'}; } |
|
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
|
|
|
&devalidate($symb,$stuname,$domain); |
|
|
$symb=escape($symb); |
$symb=escape($symb); |
if (!$namespace) { |
if (!$namespace) { |
Line 1494 sub cstore {
|
Line 1517 sub cstore {
|
return ''; |
return ''; |
} |
} |
} |
} |
if (!$domain) { $domain=$ENV{'user.domain'}; } |
|
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
|
if (!$home) { $home=$ENV{'user.home'}; } |
if (!$home) { $home=$ENV{'user.home'}; } |
|
|
my $namevalue=''; |
my $namevalue=''; |
Line 1746 sub dump {
|
Line 1767 sub dump {
|
|
|
# --------------------------------------------------------------- currentdump |
# --------------------------------------------------------------- currentdump |
sub currentdump { |
sub currentdump { |
my ($namespace,$udomain,$uname)=@_; |
my ($courseid,$sdom,$sname)=@_; |
if (!$udomain) { $udomain = $ENV{'user.domain'}; } |
$courseid = $ENV{'request.course.id'} if (! defined($courseid)); |
if (!$uname) { $uname = $ENV{'user.name'}; } |
$sdom = $ENV{'user.domain'} if (! defined($sdom)); |
my $uhome = &homeserver($uname,$udomain); |
$sname = $ENV{'user.name'} if (! defined($sname)); |
my $rep=reply("currentdump:$udomain:$uname:$namespace",$uhome); |
my $uhome = &homeserver($sname,$sdom); |
|
my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
return if ($rep =~ /^(error:|no_such_host)/); |
return if ($rep =~ /^(error:|no_such_host)/); |
# |
# |
my %returnhash=(); |
my %returnhash=(); |
Line 1758 sub currentdump {
|
Line 1780 sub currentdump {
|
if ($rep eq "unknown_cmd") { |
if ($rep eq "unknown_cmd") { |
# an old lond will not know currentdump |
# an old lond will not know currentdump |
# Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
my @tmp = &dump($namespace,$udomain,$uname,'.'); |
my @tmp = &dump($courseid,$sdom,$sname,'.'); |
return if ($tmp[0] =~ /^(error:|no_such_host)/); |
return if ($tmp[0] =~ /^(error:|no_such_host)/); |
my %hash = @tmp; |
my %hash = @tmp; |
@tmp=(); |
@tmp=(); |
Line 2147 sub is_on_map {
|
Line 2169 sub is_on_map {
|
my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
my $pathname=$uri; |
my $pathname=$uri; |
$pathname=~s|/\Q$filename\E$||; |
$pathname=~s|/\Q$filename\E$||; |
|
$pathname=~s/^adm\/wrapper\///; |
#Trying to find the conditional for the file |
#Trying to find the conditional for the file |
my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
/\&\Q$filename\E\:([\d\|]+)\&/); |
/\&\Q$filename\E\:([\d\|]+)\&/); |
Line 2808 sub EXT {
|
Line 2831 sub EXT {
|
my ($varname,$symbparm,$udom,$uname,)=@_; |
my ($varname,$symbparm,$udom,$uname,)=@_; |
|
|
unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
|
|
#get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
my $courseid; |
my $courseid; |
if (!($uname && $udom)) { |
if (!($uname && $udom)) { |
Line 2832 sub EXT {
|
Line 2854 sub EXT {
|
if ($realm eq 'user') { |
if ($realm eq 'user') { |
# --------------------------------------------------------------- user.resource |
# --------------------------------------------------------------- user.resource |
if ($space eq 'resource') { |
if ($space eq 'resource') { |
my %restored=&restore(undef,undef,$udom,$uname); |
if (defined($Apache::lonhomework::parsing_a_problem)) { |
return $restored{$qualifierrest}; |
return $Apache::lonhomework::history{$qualifierrest}; |
|
} else { |
|
my %restored=&restore($symbparm,$courseid,$udom,$uname); |
|
return $restored{$qualifierrest}; |
|
} |
# ----------------------------------------------------------------- user.access |
# ----------------------------------------------------------------- user.access |
} elsif ($space eq 'access') { |
} elsif ($space eq 'access') { |
# FIXME - not supporting calls for a specific user |
# FIXME - not supporting calls for a specific user |
Line 2868 sub EXT {
|
Line 2894 sub EXT {
|
return $uname; |
return $uname; |
# ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
} else { |
} else { |
my $item=($rest)?$qualifier.'.'.$rest:$qualifier; |
my %reply=&get($space,[$qualifierrest],$udom,$uname); |
my %reply=&get($space,[$item]); |
return $reply{$qualifierrest}; |
return $reply{$item}; |
|
} |
} |
} elsif ($realm eq 'query') { |
} elsif ($realm eq 'query') { |
# ---------------------------------------------- pull stuff out of query string |
# ---------------------------------------------- pull stuff out of query string |
Line 2987 sub EXT {
|
Line 3012 sub EXT {
|
|
|
# ------------------------------------------------------------------ Cascade up |
# ------------------------------------------------------------------ Cascade up |
unless ($space eq '0') { |
unless ($space eq '0') { |
my ($part,$id)=split(/\_/,$space); |
my @parts=split(/_/,$space); |
if ($id) { |
my $id=pop(@parts); |
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
my $part=join('_',@parts); |
$symbparm,$udom,$uname); |
if ($part eq '') { $part='0'; } |
if (defined($partgeneral)) { return $partgeneral; } |
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
} else { |
$symbparm,$udom,$uname); |
my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, |
if (defined($partgeneral)) { return $partgeneral; } |
$symbparm,$udom,$uname); |
|
if (defined($resourcegeneral)) { return $resourcegeneral; } |
|
} |
|
} |
} |
|
|
# ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
Line 3018 sub EXT {
|
Line 3040 sub EXT {
|
return ''; |
return ''; |
} |
} |
|
|
|
sub add_prefix_and_part { |
|
my ($prefix,$part)=@_; |
|
my $keyroot; |
|
if (defined($prefix) && $prefix !~ /^__/) { |
|
# prefix that has a part already |
|
$keyroot=$prefix; |
|
} elsif (defined($prefix)) { |
|
# prefix that is missing a part |
|
if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); } |
|
} else { |
|
# no prefix at all |
|
if (defined($part)) { $keyroot='_'.$part; } |
|
} |
|
return $keyroot; |
|
} |
|
|
# ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
|
|
sub metadata { |
sub metadata { |
Line 3046 sub metadata {
|
Line 3084 sub metadata {
|
} |
} |
my %metathesekeys=(); |
my %metathesekeys=(); |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); |
my $metastring=&getfile(&filelocation('',&clutter($filename))); |
my $parser=HTML::LCParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
my $token; |
my $token; |
undef %metathesekeys; |
undef %metathesekeys; |
Line 3057 sub metadata {
|
Line 3095 sub metadata {
|
# This is a package - get package info |
# This is a package - get package info |
# |
# |
my $package=$token->[2]->{'package'}; |
my $package=$token->[2]->{'package'}; |
my $keyroot=''; |
my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
if ($prefix) { |
|
$keyroot.=$prefix; |
|
} else { |
|
if (defined($token->[2]->{'part'})) { |
|
$keyroot.='_'.$token->[2]->{'part'}; |
|
} |
|
} |
|
if (defined($token->[2]->{'id'})) { |
if (defined($token->[2]->{'id'})) { |
$keyroot.='_'.$token->[2]->{'id'}; |
$keyroot.='_'.$token->[2]->{'id'}; |
} |
} |
Line 3085 sub metadata {
|
Line 3116 sub metadata {
|
my $unikey='parameter'.$keyroot.'_'.$name; |
my $unikey='parameter'.$keyroot.'_'.$name; |
$metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
$metacache{$uri.':'.$unikey.'.part'}=$part; |
$metacache{$uri.':'.$unikey.'.part'}=$part; |
unless |
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
(defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
$metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
$metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
} |
|
if (defined($metacache{$uri.':'.$unikey.'.default'})) { |
|
$metacache{$uri.':'.$unikey}= |
|
$metacache{$uri.':'.$unikey.'.default'} |
} |
} |
} |
} |
} |
} |
Line 3102 sub metadata {
|
Line 3136 sub metadata {
|
} else { |
} else { |
$unikey=$entry; |
$unikey=$entry; |
} |
} |
if ($prefix) { |
$unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
$unikey.=$prefix; |
|
} else { |
|
if (defined($token->[2]->{'part'})) { |
|
$unikey.='_'.$token->[2]->{'part'}; |
|
} |
|
} |
|
if (defined($token->[2]->{'id'})) { |
if (defined($token->[2]->{'id'})) { |
$unikey.='_'.$token->[2]->{'id'}; |
$unikey.='_'.$token->[2]->{'id'}; |
} |
} |
Line 3137 sub metadata {
|
Line 3166 sub metadata {
|
foreach (@{$token->[3]}) { |
foreach (@{$token->[3]}) { |
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
} |
} |
unless ( |
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
$metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) |
my $default=$metacache{$uri.':'.$unikey.'.default'}; |
) { $metacache{$uri.':'.$unikey}= |
if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
$metacache{$uri.':'.$unikey.'.default'}; |
# only ws inside the tag, and not in default, so use default |
} |
# as value |
|
$metacache{$uri.':'.$unikey}=$default; |
|
} else { |
|
# either something interesting inside the tag or default |
|
# uninteresting |
|
$metacache{$uri.':'.$unikey}=$internaltext; |
|
} |
# end of not-a-package not-a-library import |
# end of not-a-package not-a-library import |
} |
} |
# end of not-a-package start tag |
# end of not-a-package start tag |
Line 3149 sub metadata {
|
Line 3184 sub metadata {
|
# the next is the end of "start tag" |
# the next is the end of "start tag" |
} |
} |
} |
} |
$metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
# are there custom rights to evaluate |
|
if ($metacache{$uri.':copyright'} eq 'custom') { |
|
|
|
# |
|
# Importing a rights file here |
|
# |
|
unless ($depthcount) { |
|
my $location=$metacache{$uri.':customdistributionfile'}; |
|
my $dir=$filename; |
|
$dir=~s|[^/]*$||; |
|
$location=&filelocation($dir,$location); |
|
foreach (sort(split(/\,/,&metadata($uri,'keys', |
|
$location,'_rights', |
|
$depthcount+1)))) { |
|
$metathesekeys{$_}=1; |
|
} |
|
} |
|
} |
|
$metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri); |
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metacache{$uri.':cachedtimestamp'}=time; |
$metacache{$uri.':cachedtimestamp'}=time; |
Line 3554 BEGIN {
|
Line 3607 BEGIN {
|
} |
} |
} |
} |
|
|
|
# ------------------------------------------------------------ Read domain file |
|
{ |
|
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
|
'/domain.tab'); |
|
%domaindescription = (); |
|
%domain_auth_def = (); |
|
%domain_auth_arg_def = (); |
|
if ($fh) { |
|
while (<$fh>) { |
|
next if /^\#/; |
|
chomp; |
|
my ($domain, $domain_description, $def_auth, $def_auth_arg) |
|
= split(/:/,$_,4); |
|
$domain_auth_def{$domain}=$def_auth; |
|
$domain_auth_arg_def{$domain}=$def_auth_arg; |
|
$domaindescription{$domain}=$domain_description; |
|
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
|
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
|
} |
|
} |
|
} |
|
|
|
|
# ------------------------------------------------------------- Read hosts file |
# ------------------------------------------------------------- Read hosts file |
{ |
{ |
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
Line 3567 BEGIN {
|
Line 3643 BEGIN {
|
$hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
$hostip{$id}=$ip; |
$hostip{$id}=$ip; |
$iphost{$ip}=$id; |
$iphost{$ip}=$id; |
if ($domdescr) { $domaindescription{$domain}=$domdescr; } |
|
if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
} else { |
} else { |
if ($configline) { |
if ($configline) { |
Line 3629 BEGIN {
|
Line 3704 BEGIN {
|
} |
} |
} |
} |
|
|
|
# ------------- set up temporary directory |
|
{ |
|
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
|
|
|
} |
|
|
%metacache=(); |
%metacache=(); |
|
|
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |