loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.304 and 1.335

version 1.304, 2002/12/04 15:23:39	version 1.335, 2003/03/07 23:37:09
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 80 use vars	Line 75 use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom	qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache	%libserv %pr %prp %metacache %packagetab %titlecache
%courselogs %accesshash $processmarker $dumpcount	%courselogs %accesshash $processmarker $dumpcount
%coursedombuf %coursehombuf %courseresdatacache %domaindescription);	%coursedombuf %coursehombuf %courseresdatacache
	%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 142 sub reply {	Line 138 sub reply {
unless (defined($hostname{$server})) { return 'no_such_host'; }	unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
#sleep 5;	#sleep 5;
#$answer=subreply($cmd,$server);	#$answer=subreply($cmd,$server);
#if ($answer eq 'con_lost') {	#if ($answer eq 'con_lost') {
# &logthis("Second attempt con_lost on $server");	# &logthis("Second attempt con_lost on $server");
# my $peerfile="$perlvar{'lonSockDir'}/$server";	# my $peerfile="$perlvar{'lonSockDir'}/$server";
# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",	# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
Line 215 sub critical {	Line 211 sub critical {
$middlename=substr($middlename,0,16);	$middlename=substr($middlename,0,16);
$middlename=~s/\W//g;	$middlename=~s/\W//g;
my $dfilename=	my $dfilename=
"$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";	"$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
	$dumpcount++;
{	{
my $dfh;	my $dfh;
if ($dfh=Apache::File->new(">$dfilename")) {	if ($dfh=Apache::File->new(">$dfilename")) {
Line 727 sub currentversion {	Line 724 sub currentversion {

sub subscribe {	sub subscribe {
my $fname=shift;	my $fname=shift;
	if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }
my $author=$fname;	my $author=$fname;
$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 806 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 829 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 854 sub tokenwrapper {	Line 872 sub tokenwrapper {
sub userfileupload {	sub userfileupload {
my ($formname,$coursedoc)=@_;	my ($formname,$coursedoc)=@_;
my $fname=$ENV{'form.'.$formname.'.filename'};	my $fname=$ENV{'form.'.$formname.'.filename'};
	# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;	$fname=~s/\\/\//g;
	# Get rid of everything but the actual filename
$fname=~s/^.*\/([^\/]+)$/$1/;	$fname=~s/^.*\/([^\/]+)$/$1/;
	# Replace spaces by underscores
	$fname=~s/\s+/\_/g;
	# Replace all other weird characters by nothing
	$fname=~s/[^\w\.\-]//g;
	# 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});
# Create the directory if not present	# Create the directory if not present
Line 1099 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 1113 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 1445 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 1453 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 1476 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 1484 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 1734 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 1861 sub allowed {	Line 1944 sub allowed {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

	# URI is an uploaded document for this course

	if (($priv eq 'bre') &&
	($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {
	return 'F';
	}
# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.

if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
Line 2080 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 2347 sub modifyuser {	Line 2437 sub modifyuser {
}	}
}	}
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
my %names=&get('environment',	my @tmp=&get('environment',
['firstname','middlename','lastname','generation'],	['firstname','middlename','lastname','generation'],
$udom,$uname);	$udom,$uname);
if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }	my %names;
	if ($tmp[0] =~ m/^error:.*/) {
	%names=();
	} else {
	%names = @tmp;
	}
if ($first) { $names{'firstname'} = $first; }	if ($first) { $names{'firstname'} = $first; }
if ($middle) { $names{'middlename'} = $middle; }	if ($middle) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }	if ($last) { $names{'lastname'} = $last; }
Line 2718 sub courseresdata {	Line 2813 sub courseresdata {
if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {	if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {
$courseresdatacache{$hashid.'.time'}=time;	$courseresdatacache{$hashid.'.time'}=time;
$courseresdatacache{$hashid}=\%dumpreply;	$courseresdatacache{$hashid}=\%dumpreply;
	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
	return $tmp;
}	}
}	}
foreach my $item (@which) {	foreach my $item (@which) {
Line 2743 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 2758 sub EXT {	Line 2855 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 2794 sub EXT {	Line 2895 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 2844 sub EXT {	Line 2944 sub EXT {
my $courselevelm=$courseid.'.'.$mapparm;	my $courselevelm=$courseid.'.'.$mapparm;

# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user
my %resourcedata=&get('resourcedata',	#most student don't have any data set, check if there is some data
[$courselevelr,$courselevelm,$courselevel],	#every thirty minutes
$udom,$uname);	if (!
if (($resourcedata{$courselevelr}!~/^error\:/) &&	(exists($ENV{'cache.studentresdata'})
($resourcedata{$courselevelr}!~/^con_lost/)) {	&& (($ENV{'cache.studentresdata'}+1800) > time))) {
	my %resourcedata=&get('resourcedata',
if ($resourcedata{$courselevelr}) {	[$courselevelr,$courselevelm,$courselevel],
return $resourcedata{$courselevelr}; }	$udom,$uname);
if ($resourcedata{$courselevelm}) {	my ($tmp)=keys(%resourcedata);
return $resourcedata{$courselevelm}; }	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
if ($resourcedata{$courselevel}) {	if ($resourcedata{$courselevelr}) {
return $resourcedata{$courselevel}; }	return $resourcedata{$courselevelr}; }
} else {	if ($resourcedata{$courselevelm}) {
if ($resourcedata{$courselevelr}!~/No such file/) {	return $resourcedata{$courselevelm}; }
&logthis("<font color=blue>WARNING:".	if ($resourcedata{$courselevel}) {
" Trying to get resource data for ".	return $resourcedata{$courselevel}; }
$uname." at ".$udom.": ".	} else {
$resourcedata{$courselevelr}."</font>");	if ($tmp!~/No such file/) {
	&logthis("<font color=blue>WARNING:".
	" Trying to get resource data for ".
	$uname." at ".$udom.": ".
	$tmp."</font>");
	} elsif ($tmp=~/error:No such file/) {
	$ENV{'cache.studentresdata'}=time;
	&appenv(('cache.studentresdata'=>
	$ENV{'cache.studentresdata'}));
	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
	return $tmp;
	}
}	}
}	}

Line 2902 sub EXT {	Line 3013 sub EXT {

# ------------------------------------------------------------------ Cascade up	# ------------------------------------------------------------------ Cascade up
unless ($space eq '0') {	unless ($space eq '0') {
my ($part,$id)=split(/\_/,$space);	my ($part,$id)=split(/_/,$space);
if ($id) {	if ($id) {
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,	my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
$symbparm,$udom,$uname);	$symbparm,$udom,$uname);
Line 2933 sub EXT {	Line 3044 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 2961 sub metadata {	Line 3088 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 2972 sub metadata {	Line 3099 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 3000 sub metadata {	Line 3120 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 3017 sub metadata {	Line 3140 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 3052 sub metadata {	Line 3170 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 3469 BEGIN {	Line 3593 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 3482 BEGIN {	Line 3629 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 3544 BEGIN {	Line 3690 BEGIN {
}	}
}	}

	# ------------- set up temporary directory
	{
	$tmpdir = $perlvar{'lonDaemons'}.'/tmp/';

	}

%metacache=();	%metacache=();

$processmarker='_'.time.'_'.$perlvar{'lonHostID'};	$processmarker='_'.time.'_'.$perlvar{'lonHostID'};

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.304
changed lines
	Added in v.1.335