version 1.316, 2003/01/10 20:55:44
|
version 1.334, 2003/03/06 22:41:41
|
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 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 864 sub userfileupload {
|
Line 879 sub userfileupload {
|
# Replace spaces by underscores |
# Replace spaces by underscores |
$fname=~s/\s+/\_/g; |
$fname=~s/\s+/\_/g; |
# Replace all other weird characters by nothing |
# Replace all other weird characters by nothing |
$fname=~s/[^\w\.\-\+]//g; |
$fname=~s/[^\w\.\-]//g; |
# See if there is anything left |
# See if there is anything left |
unless ($fname) { return 'error: no uploaded file'; } |
unless ($fname) { return 'error: no uploaded file'; } |
chop($ENV{'form.'.$formname}); |
chop($ENV{'form.'.$formname}); |
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 1744 sub dump {
|
Line 1765 sub dump {
|
return %returnhash; |
return %returnhash; |
} |
} |
|
|
|
# --------------------------------------------------------------- currentdump |
|
sub currentdump { |
|
my ($courseid,$sdom,$sname)=@_; |
|
$courseid = $ENV{'request.course.id'} if (! defined($courseid)); |
|
$sdom = $ENV{'user.domain'} if (! defined($sdom)); |
|
$sname = $ENV{'user.name'} if (! defined($sname)); |
|
my $uhome = &homeserver($sname,$sdom); |
|
my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
|
return if ($rep =~ /^(error:|no_such_host)/); |
|
# |
|
my %returnhash=(); |
|
# |
|
if ($rep eq "unknown_cmd") { |
|
# an old lond will not know currentdump |
|
# Do a dump and make it look like a currentdump |
|
my @tmp = &dump($courseid,$sdom,$sname,'.'); |
|
return if ($tmp[0] =~ /^(error:|no_such_host)/); |
|
my %hash = @tmp; |
|
@tmp=(); |
|
# Code ripped from lond, essentially. The only difference |
|
# here is the unescaping done by lonnet::dump(). Conceivably |
|
# we might run in to problems with parameter names =~ /^v\./ |
|
while (my ($key,$value) = each(%hash)) { |
|
my ($v,$symb,$param) = split(/:/,$key); |
|
next if ($v eq 'version' || $symb eq 'keys'); |
|
next if (exists($returnhash{$symb}) && |
|
exists($returnhash{$symb}->{$param}) && |
|
$returnhash{$symb}->{'v.'.$param} > $v); |
|
$returnhash{$symb}->{$param}=$value; |
|
$returnhash{$symb}->{'v.'.$param}=$v; |
|
} |
|
# |
|
# Remove all of the keys in the hashes which keep track of |
|
# the version of the parameter. |
|
while (my ($symb,$param_hash) = each(%returnhash)) { |
|
# use a foreach because we are going to delete from the hash. |
|
foreach my $key (keys(%$param_hash)) { |
|
delete($param_hash->{$key}) if ($key =~ /^v\./); |
|
} |
|
} |
|
} else { |
|
my @pairs=split(/\&/,$rep); |
|
foreach (@pairs) { |
|
my ($key,$value)=split(/=/,$_); |
|
my ($symb,$param) = split(/:/,$key); |
|
$returnhash{&unescape($symb)}->{&unescape($param)} = |
|
&unescape($value); |
|
} |
|
} |
|
return %returnhash; |
|
} |
|
|
# --------------------------------------------------------------- put interface |
# --------------------------------------------------------------- put interface |
|
|
sub put { |
sub put { |
Line 2096 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 2766 sub EXT {
|
Line 2840 sub EXT {
|
} else { |
} else { |
$courseid=$ENV{'request.course.id'}; |
$courseid=$ENV{'request.course.id'}; |
} |
} |
|
|
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); |
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); |
my $rest; |
my $rest; |
if ($therest[0]) { |
if (defined($therest[0])) { |
$rest=join('.',@therest); |
$rest=join('.',@therest); |
} else { |
} else { |
$rest=''; |
$rest=''; |
} |
} |
|
|
my $qualifierrest=$qualifier; |
my $qualifierrest=$qualifier; |
if ($rest) { $qualifierrest.='.'.$rest; } |
if ($rest) { $qualifierrest.='.'.$rest; } |
my $spacequalifierrest=$space; |
my $spacequalifierrest=$space; |
Line 2967 sub EXT {
|
Line 3041 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 3006 sub metadata {
|
Line 3096 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 3034 sub metadata {
|
Line 3117 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 3051 sub metadata {
|
Line 3137 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 3086 sub metadata {
|
Line 3167 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 3503 BEGIN {
|
Line 3590 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 3516 BEGIN {
|
Line 3626 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 3578 BEGIN {
|
Line 3687 BEGIN {
|
} |
} |
} |
} |
|
|
|
# ------------- set up temporary directory |
|
{ |
|
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
|
|
|
} |
|
|
%metacache=(); |
%metacache=(); |
|
|
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |