|
version 1.394, 2003/07/25 01:18:04
|
version 1.426, 2003/10/04 02:34:01
|
|
Line 76 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 %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache |
| %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); |
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
| |
%domain_lang_def %domain_city %domain_longi %domain_lati $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); |
| use HTML::LCParser; |
use HTML::LCParser; |
| use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
| use Apache::loncoursedata; |
use Apache::loncoursedata; |
| |
use Apache::lonlocal; |
| |
use Storable qw(lock_store lock_nstore lock_retrieve); |
| |
use Time::HiRes(); |
| my $readit; |
my $readit; |
| |
|
| # --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
Line 243 sub critical {
|
Line 247 sub critical {
|
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
| |
|
| |
# |
| |
# -------------- Remove all key from the env that start witha lowercase letter |
| |
# (Which is always a lon-capa value) |
| |
|
| |
sub cleanenv { |
| |
# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; } |
| |
# unless (&Apache::exists_config_define("MODPERL2")) { return; } |
| |
foreach my $key (keys(%ENV)) { |
| |
if ($key =~ /^[a-z]/) { |
| |
delete($ENV{$key}); |
| |
} |
| |
} |
| |
} |
| |
|
| # ------------------------------------------- Transfer profile into environment |
# ------------------------------------------- Transfer profile into environment |
| |
|
|
Line 377 sub userload {
|
Line 395 sub userload {
|
| my $curtime=time; |
my $curtime=time; |
| while ($filename=readdir(LONIDS)) { |
while ($filename=readdir(LONIDS)) { |
| if ($filename eq '.' || $filename eq '..') {next;} |
if ($filename eq '.' || $filename eq '..') {next;} |
| my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8]; |
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; |
| if ($curtime-$atime < 3600) { $numusers++; } |
if ($curtime-$mtime < 3600) { $numusers++; } |
| } |
} |
| closedir(LONIDS); |
closedir(LONIDS); |
| } |
} |
|
Line 424 sub spareserver {
|
Line 442 sub spareserver {
|
| my $lowestserver=$loadpercent > $userloadpercent? |
my $lowestserver=$loadpercent > $userloadpercent? |
| $loadpercent : $userloadpercent; |
$loadpercent : $userloadpercent; |
| foreach $tryserver (keys %spareid) { |
foreach $tryserver (keys %spareid) { |
| my $loadans=reply('load',$tryserver); |
my $loadans=reply('load',$tryserver); |
| my $userloadans=reply('userload',$tryserver); |
my $userloadans=reply('userload',$tryserver); |
| if ($userloadans !~ /\d/) { $userloadans=0; } |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
| my $answer=$loadans > $userloadans? |
next; #didn't get a number from the server |
| $loadans : $userloadans; |
} |
| if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
my $answer; |
| $spareserver="http://$hostname{$tryserver}"; |
if ($loadans =~ /\d/) { |
| $lowestserver=$answer; |
if ($userloadans =~ /\d/) { |
| } |
#both are numbers, pick the bigger one |
| |
$answer=$loadans > $userloadans? |
| |
$loadans : $userloadans; |
| |
} else { |
| |
$answer = $loadans; |
| |
} |
| |
} else { |
| |
$answer = $userloadans; |
| |
} |
| |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
| |
$spareserver="http://$hostname{$tryserver}"; |
| |
$lowestserver=$answer; |
| |
} |
| } |
} |
| return $spareserver; |
return $spareserver; |
| } |
} |
|
Line 556 sub authenticate {
|
Line 586 sub authenticate {
|
| sub homeserver { |
sub homeserver { |
| my ($uname,$udom,$ignoreBadCache)=@_; |
my ($uname,$udom,$ignoreBadCache)=@_; |
| my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
| if ($homecache{$index}) { |
|
| return "$homecache{$index}"; |
my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); |
| } |
if (defined($cached)) { return $result; } |
| my $tryserver; |
my $tryserver; |
| foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
| next if ($ignoreBadCache ne 'true' && |
next if ($ignoreBadCache ne 'true' && |
|
Line 566 sub homeserver {
|
Line 596 sub homeserver {
|
| if ($hostdom{$tryserver} eq $udom) { |
if ($hostdom{$tryserver} eq $udom) { |
| my $answer=reply("home:$udom:$uname",$tryserver); |
my $answer=reply("home:$udom:$uname",$tryserver); |
| if ($answer eq 'found') { |
if ($answer eq 'found') { |
| $homecache{$index}=$tryserver; |
return &do_cache(\%homecache,$index,$tryserver,'home'); |
| return $tryserver; |
|
| } elsif ($answer eq 'no_host') { |
} elsif ($answer eq 'no_host') { |
| $badServerCache{$tryserver}=1; |
$badServerCache{$tryserver}=1; |
| } |
} |
|
Line 819 sub getsection {
|
Line 848 sub getsection {
|
| return '-1'; |
return '-1'; |
| } |
} |
| |
|
| |
sub devalidate_cache { |
| |
my ($cache,$id) = @_; |
| |
delete $$cache{$id.'.time'}; |
| |
delete $$cache{$id}; |
| |
} |
| |
|
| |
sub is_cached { |
| |
my ($cache,$id,$name,$time) = @_; |
| |
if (!$time) { $time=300; } |
| |
if (!exists($$cache{$id.'.time'})) { |
| |
&load_cache($cache,$name); |
| |
} |
| |
if (!exists($$cache{$id.'.time'})) { |
| |
# &logthis("Didn't find $id"); |
| |
return (undef,undef); |
| |
} else { |
| |
if (time-($$cache{$id.'.time'})>$time) { |
| |
# &logthis("Devailidating $id"); |
| |
&devalidate_cache($cache,$id); |
| |
return (undef,undef); |
| |
} |
| |
} |
| |
return ($$cache{$id},1); |
| |
} |
| |
|
| |
sub do_cache { |
| |
my ($cache,$id,$value,$name) = @_; |
| |
$$cache{$id.'.time'}=time; |
| |
$$cache{$id}=$value; |
| |
&save_cache($cache,$name); |
| |
# do_cache implictly return the set value |
| |
$$cache{$id}; |
| |
} |
| |
|
| |
sub save_cache { |
| |
my ($cache,$name)=@_; |
| |
# my $starttime=&Time::HiRes::time(); |
| |
# &logthis("Saving :$name:"); |
| |
eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); |
| |
if ($@) { &logthis("lock_store threw a die ".$@); } |
| |
# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime)); |
| |
} |
| |
|
| |
sub load_cache { |
| |
my ($cache,$name)=@_; |
| |
# my $starttime=&Time::HiRes::time(); |
| |
# &logthis("Before Loading $name size is ".scalar(%$cache)); |
| |
my $tmpcache; |
| |
eval { |
| |
$tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); |
| |
}; |
| |
if ($@) { &logthis("lock_retreive threw a die ".$@); return; } |
| |
if (!%$cache) { |
| |
my $count; |
| |
while (my ($key,$value)=each(%$tmpcache)) { |
| |
$count++; |
| |
$$cache{$key}=$value; |
| |
} |
| |
# &logthis("Initial load: $count"); |
| |
} else { |
| |
my $key; |
| |
my $count; |
| |
while ($key=each(%$tmpcache)) { |
| |
if ($key !~/^(.*)\.time$/) { next; } |
| |
my $name=$1; |
| |
if (exists($$cache{$key})) { |
| |
if ($$tmpcache{$key} >= $$cache{$key}) { |
| |
$$cache{$key}=$$tmpcache{$key}; |
| |
$$cache{$name}=$$tmpcache{$name}; |
| |
} else { |
| |
# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!"); |
| |
} |
| |
} else { |
| |
$count++; |
| |
$$cache{$key}=$$tmpcache{$key}; |
| |
$$cache{$name}=$$tmpcache{$name}; |
| |
} |
| |
} |
| |
# &logthis("Additional load: $count"); |
| |
} |
| |
# &logthis("After Loading $name size is ".scalar(%$cache)); |
| |
# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); |
| |
} |
| |
|
| sub usection { |
sub usection { |
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
| |
my $hashid="$udom:$unam:$courseid"; |
| |
|
| |
my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection'); |
| |
if (defined($cached)) { return $result; } |
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
| $courseid=~s/^(\w)/\/$1/; |
$courseid=~s/^(\w)/\/$1/; |
| foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', |
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', |
|
Line 839 sub usection {
|
Line 956 sub usection {
|
| if ($end) { |
if ($end) { |
| if ($now>$end) { $notactive=1; } |
if ($now>$end) { $notactive=1; } |
| } |
} |
| unless ($notactive) { return $section; } |
unless ($notactive) { |
| |
return &do_cache(\%usectioncache,$hashid,$section,'usection'); |
| |
} |
| } |
} |
| } |
} |
| return '-1'; |
return &do_cache(\%usectioncache,$hashid,'-1','usection'); |
| } |
} |
| |
|
| # ------------------------------------- Read an entry from a user's environment |
# ------------------------------------- Read an entry from a user's environment |
|
Line 1216 sub courseacclog {
|
Line 1335 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)$/) { |
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { |
| $what.=':POST'; |
$what.=':POST'; |
| foreach (keys %ENV) { |
foreach (keys %ENV) { |
| if ($_=~/^form\.(.*)/) { |
if ($_=~/^form\.(.*)/) { |
|
Line 1284 sub get_course_adv_roles {
|
Line 1403 sub get_course_adv_roles {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub get_my_roles { |
| |
my ($uname,$udom)=@_; |
| |
unless (defined($uname)) { $uname=$ENV{'user.name'}; } |
| |
unless (defined($udom)) { $udom=$ENV{'user.domain'}; } |
| |
my %dumphash= |
| |
&dump('nohist_userroles',$udom,$uname); |
| |
my %returnhash=(); |
| |
my $now=time; |
| |
foreach (keys %dumphash) { |
| |
my ($tend,$tstart)=split(/\:/,$dumphash{$_}); |
| |
if (($tstart) && ($tstart<0)) { next; } |
| |
if (($tend) && ($tend<$now)) { next; } |
| |
if (($tstart) && ($now<$tstart)) { next; } |
| |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
| |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
# ----------------------------------------------------- Frontpage Announcements |
| |
# |
| |
# |
| |
|
| |
sub postannounce { |
| |
my ($server,$text)=@_; |
| |
unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } |
| |
unless ($text=~/\w/) { $text=''; } |
| |
return &reply('setannounce:'.&escape($text),$server); |
| |
} |
| |
|
| |
sub getannounce { |
| |
if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { |
| |
my $announcement=''; |
| |
while (<$fh>) { $announcement .=$_; } |
| |
$fh->close(); |
| |
if ($announcement=~/\w/) { |
| |
return |
| |
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. |
| |
'<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>'; |
| |
} else { |
| |
return ''; |
| |
} |
| |
} else { |
| |
return ''; |
| |
} |
| |
} |
| |
|
| # ---------------------------------------------------------- Course ID routines |
# ---------------------------------------------------------- Course ID routines |
| # Deal with domain's nohist_courseid.db files |
# Deal with domain's nohist_courseid.db files |
| # |
# |
|
Line 2077 sub dump {
|
Line 2243 sub dump {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
# -------------------------------------------------------------- keys interface |
| |
|
| |
sub getkeys { |
| |
my ($namespace,$udomain,$uname)=@_; |
| |
if (!$udomain) { $udomain=$ENV{'user.domain'}; } |
| |
if (!$uname) { $uname=$ENV{'user.name'}; } |
| |
my $uhome=&homeserver($uname,$udomain); |
| |
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); |
| |
my @keyarray=(); |
| |
foreach (split(/\&/,$rep)) { |
| |
push (@keyarray,&unescape($_)); |
| |
} |
| |
return @keyarray; |
| |
} |
| |
|
| # --------------------------------------------------------------- currentdump |
# --------------------------------------------------------------- currentdump |
| sub currentdump { |
sub currentdump { |
| my ($courseid,$sdom,$sname)=@_; |
my ($courseid,$sdom,$sname)=@_; |
|
Line 2096 sub currentdump {
|
Line 2277 sub currentdump {
|
| return if ($tmp[0] =~ /^(error:|no_such_host)/); |
return if ($tmp[0] =~ /^(error:|no_such_host)/); |
| my %hash = @tmp; |
my %hash = @tmp; |
| @tmp=(); |
@tmp=(); |
| # Code ripped from lond, essentially. The only difference |
%returnhash = %{&convert_dump_to_currentdump(\%hash)}; |
| # 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 { |
} else { |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| foreach (@pairs) { |
foreach (@pairs) { |
|
Line 2129 sub currentdump {
|
Line 2290 sub currentdump {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub convert_dump_to_currentdump{ |
| |
my %hash = %{shift()}; |
| |
my %returnhash; |
| |
# 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\./); |
| |
} |
| |
} |
| |
return \%returnhash; |
| |
} |
| |
|
| # --------------------------------------------------------------- put interface |
# --------------------------------------------------------------- put interface |
| |
|
| sub put { |
sub put { |
|
Line 2209 sub customaccess {
|
Line 2397 sub customaccess {
|
| $access=($effect eq 'allow'); |
$access=($effect eq 'allow'); |
| last; |
last; |
| } |
} |
| |
if ($realm eq '' && $role eq '') { |
| |
$access=($effect eq 'allow'); |
| |
} |
| } |
} |
| return $access; |
return $access; |
| } |
} |
|
Line 2221 sub allowed {
|
Line 2412 sub allowed {
|
| my $orguri=$uri; |
my $orguri=$uri; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| |
|
| |
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } |
| # Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
| |
|
| if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
|
Line 2512 sub is_on_map {
|
Line 2704 sub is_on_map {
|
| if ($match) { |
if ($match) { |
| return (1,$1); |
return (1,$1); |
| } else { |
} else { |
| return (0,0); |
my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/); |
| |
$ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
| |
/\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/; |
| |
return (0,$2,$pathname.'/'.$1); |
| } |
} |
| } |
} |
| |
|
|
Line 2642 sub userlog_query {
|
Line 2837 sub userlog_query {
|
| |
|
| sub plaintext { |
sub plaintext { |
| my $short=shift; |
my $short=shift; |
| return $prp{$short}; |
return &mt($prp{$short}); |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Assign Role |
# ----------------------------------------------------------------- Assign Role |
|
Line 2746 sub modifyuser {
|
Line 2941 sub modifyuser {
|
| ' in domain '.$ENV{'request.role.domain'}); |
' in domain '.$ENV{'request.role.domain'}); |
| my $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
| # ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
| if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
if (($uhome eq 'no_host') && |
| |
(($umode && $upass) || ($umode eq 'localauth'))) { |
| my $unhome=''; |
my $unhome=''; |
| if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
| $unhome = $desiredhome; |
$unhome = $desiredhome; |
|
Line 3070 sub dirlist {
|
Line 3266 sub dirlist {
|
| } |
} |
| my $alldomstr=''; |
my $alldomstr=''; |
| foreach (sort keys %alldom) { |
foreach (sort keys %alldom) { |
| $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; |
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; |
| } |
} |
| $alldomstr=~s/:$//; |
$alldomstr=~s/:$//; |
| return split(/:/,$alldomstr); |
return split(/:/,$alldomstr); |
|
Line 3086 sub dirlist {
|
Line 3282 sub dirlist {
|
| # when it was last modified. It will also return an error of -1 |
# when it was last modified. It will also return an error of -1 |
| # if an error occurs |
# if an error occurs |
| |
|
| |
## |
| |
## FIXME: This subroutine assumes its caller knows something about the |
| |
## directory structure of the home server for the student ($root). |
| |
## Not a good assumption to make. Since this is for looking up files |
| |
## in user directories, the full path should be constructed by lond, not |
| |
## whatever machine we request data from. |
| |
## |
| sub GetFileTimestamp { |
sub GetFileTimestamp { |
| my ($studentDomain,$studentName,$filename,$root)=@_; |
my ($studentDomain,$studentName,$filename,$root)=@_; |
| $studentDomain=~s/\W//g; |
$studentDomain=~s/\W//g; |
|
Line 3162 sub condval {
|
Line 3365 sub condval {
|
| sub devalidatecourseresdata { |
sub devalidatecourseresdata { |
| my ($coursenum,$coursedomain)=@_; |
my ($coursenum,$coursedomain)=@_; |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| delete $courseresdatacache{$hashid.'.time'}; |
&devalidate_cache(\%courseresdatacache,$hashid); |
| } |
} |
| |
|
| # --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
|
Line 3171 sub courseresdata {
|
Line 3374 sub courseresdata {
|
| my ($coursenum,$coursedomain,@which)=@_; |
my ($coursenum,$coursedomain,@which)=@_; |
| my $coursehom=&homeserver($coursenum,$coursedomain); |
my $coursehom=&homeserver($coursenum,$coursedomain); |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| my $dodump=0; |
my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); |
| if (!defined($courseresdatacache{$hashid.'.time'})) { |
unless (defined($cached)) { |
| $dodump=1; |
|
| } else { |
|
| if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; } |
|
| } |
|
| if ($dodump) { |
|
| my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
| |
$result=\%dumpreply; |
| my ($tmp) = keys(%dumpreply); |
my ($tmp) = keys(%dumpreply); |
| if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
| $courseresdatacache{$hashid.'.time'}=time; |
&do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
| $courseresdatacache{$hashid}=\%dumpreply; |
|
| } elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| return $tmp; |
return $tmp; |
| |
} elsif ($tmp =~ /^(error)/) { |
| |
$result=undef; |
| |
&do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
| } |
} |
| } |
} |
| foreach my $item (@which) { |
foreach my $item (@which) { |
| if (defined($courseresdatacache{$hashid}->{$item})) { |
if (defined($result->{$item})) { |
| return $courseresdatacache{$hashid}->{$item}; |
return $result->{$item}; |
| } |
} |
| } |
} |
| return undef; |
return undef; |
|
Line 3222 sub EXT_cache_set {
|
Line 3423 sub EXT_cache_set {
|
| |
|
| # --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
| sub EXT { |
sub EXT { |
| my ($varname,$symbparm,$udom,$uname,$usection)=@_; |
my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; |
| |
|
| unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
| #get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
|
Line 3323 sub EXT {
|
Line 3524 sub EXT {
|
| return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; |
return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; |
| } elsif ($realm eq 'resource') { |
} elsif ($realm eq 'resource') { |
| |
|
| |
my $section; |
| if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { |
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { |
| |
|
| #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
|
Line 3330 sub EXT {
|
Line 3532 sub EXT {
|
| # ----------------------------------------------------- Cascading lookup scheme |
# ----------------------------------------------------- Cascading lookup scheme |
| if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
| my $symbp=$symbparm; |
my $symbp=$symbparm; |
| my $mapp=(split(/\_\_\_/,$symbp))[0]; |
my $mapp=(&decode_symb($symbp))[0]; |
| |
|
| my $symbparm=$symbp.'.'.$spacequalifierrest; |
my $symbparm=$symbp.'.'.$spacequalifierrest; |
| my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
| |
|
| my $section; |
|
| if (($ENV{'user.name'} eq $uname) && |
if (($ENV{'user.name'} eq $uname) && |
| ($ENV{'user.domain'} eq $udom)) { |
($ENV{'user.domain'} eq $udom)) { |
| $section=$ENV{'request.course.sec'}; |
$section=$ENV{'request.course.sec'}; |
|
Line 3357 sub EXT {
|
Line 3558 sub EXT {
|
| |
|
| # ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
| #most student don\'t have any data set, check if there is some data |
#most student don\'t have any data set, check if there is some data |
| #every thirty minutes |
|
| if (! &EXT_cache_status($udom,$uname)) { |
if (! &EXT_cache_status($udom,$uname)) { |
| my %resourcedata=&get('resourcedata', |
my $hashid="$udom:$uname"; |
| [$courselevelr,$courselevelm,$courselevel], |
my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, |
| $udom,$uname); |
'userres'); |
| my ($tmp)=keys(%resourcedata); |
if (!defined($cached)) { |
| |
my %resourcedata=&get('resourcedata', |
| |
[$courselevelr,$courselevelm, |
| |
$courselevel],$udom,$uname); |
| |
$result=\%resourcedata; |
| |
&do_cache(\%userresdatacache,$hashid,$result,'userres'); |
| |
} |
| |
my ($tmp)=keys(%$result); |
| if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
| if ($resourcedata{$courselevelr}) { |
if ($$result{$courselevelr}) { |
| return $resourcedata{$courselevelr}; } |
return $$result{$courselevelr}; } |
| if ($resourcedata{$courselevelm}) { |
if ($$result{$courselevelm}) { |
| return $resourcedata{$courselevelm}; } |
return $$result{$courselevelm}; } |
| if ($resourcedata{$courselevel}) { |
if ($$result{$courselevel}) { |
| return $resourcedata{$courselevel}; } |
return $$result{$courselevel}; } |
| } else { |
} else { |
| if ($tmp!~/No such file/) { |
if ($tmp!~/No such file/) { |
| &logthis("<font color=blue>WARNING:". |
&logthis("<font color=blue>WARNING:". |
|
Line 3410 sub EXT {
|
Line 3617 sub EXT {
|
| my $filename; |
my $filename; |
| if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
| if ($symbparm) { |
if ($symbparm) { |
| $filename=(split(/\_\_\_/,$symbparm))[2]; |
$filename=(&decode_symb($symbparm))[2]; |
| } else { |
} else { |
| $filename=$ENV{'request.filename'}; |
$filename=$ENV{'request.filename'}; |
| } |
} |
|
Line 3426 sub EXT {
|
Line 3633 sub EXT {
|
| my $part=join('_',@parts); |
my $part=join('_',@parts); |
| if ($part eq '') { $part='0'; } |
if ($part eq '') { $part='0'; } |
| my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
| $symbparm,$udom,$uname); |
$symbparm,$udom,$uname,$section,1); |
| if (defined($partgeneral)) { return $partgeneral; } |
if (defined($partgeneral)) { return $partgeneral; } |
| } |
} |
| |
if ($recurse) { return undef; } |
| |
my $pack_def=&packages_tab_default($filename,$varname); |
| |
if (defined($pack_def)) { return $pack_def; } |
| |
|
| # ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
| } elsif ($realm eq 'environment') { |
} elsif ($realm eq 'environment') { |
|
Line 3449 sub EXT {
|
Line 3659 sub EXT {
|
| return ''; |
return ''; |
| } |
} |
| |
|
| |
sub packages_tab_default { |
| |
my ($uri,$varname)=@_; |
| |
my (undef,$part,$name)=split(/\./,$varname); |
| |
my $packages=&metadata($uri,'packages'); |
| |
foreach my $package (split(/,/,$packages)) { |
| |
my ($pack_type,$pack_part)=split(/_/,$package,2); |
| |
if ($pack_part eq $part) { |
| |
return $packagetab{"$pack_type&$name&default"}; |
| |
} |
| |
} |
| |
return undef; |
| |
} |
| |
|
| sub add_prefix_and_part { |
sub add_prefix_and_part { |
| my ($prefix,$part)=@_; |
my ($prefix,$part)=@_; |
| my $keyroot; |
my $keyroot; |
|
Line 3469 sub add_prefix_and_part {
|
Line 3692 sub add_prefix_and_part {
|
| |
|
| sub metadata { |
sub metadata { |
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
| |
|
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| # if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
| if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || |
if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || |
| ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
| |
($uri =~ m|home/[^/]+/public_html/|)) { |
| return ''; |
return ''; |
| } |
} |
| my $filename=$uri; |
my $filename=$uri; |
|
Line 3490 sub metadata {
|
Line 3713 sub metadata {
|
| if ($liburi) { |
if ($liburi) { |
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
| } |
} else { |
| |
delete($metacache{$uri.':packages'}); |
| |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring=&getfile(&filelocation('',&clutter($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; |
| delete($metacache{$uri.':packages'}); |
|
| 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'})) { |
if (defined($token->[2]->{'package'})) { |
|
Line 3517 sub metadata {
|
Line 3741 sub metadata {
|
| foreach (keys %packagetab) { |
foreach (keys %packagetab) { |
| if ($_=~/^$package\&/) { |
if ($_=~/^$package\&/) { |
| my ($pack,$name,$subp)=split(/\&/,$_); |
my ($pack,$name,$subp)=split(/\&/,$_); |
| |
# ignore package.tab specified default values |
| |
# here &package_tab_default() will fetch those |
| |
if ($subp eq 'default') { next; } |
| my $value=$packagetab{$_}; |
my $value=$packagetab{$_}; |
| my $part=$keyroot; |
my $part=$keyroot; |
| $part=~s/^\_//; |
$part=~s/^\_//; |
|
Line 3524 sub metadata {
|
Line 3751 sub metadata {
|
| $value.=' [Part: '.$part.']'; |
$value.=' [Part: '.$part.']'; |
| } |
} |
| my $unikey='parameter'.$keyroot.'_'.$name; |
my $unikey='parameter'.$keyroot.'_'.$name; |
| if ($subp eq 'default') { |
$metacache{$uri.':'.$unikey.'.part'}=$part; |
| $unikey='parameter_0_'.$name; |
$metathesekeys{$unikey}=1; |
| $metacache{$uri.':'.$unikey.'.part'}='0'; |
|
| } else { |
|
| $metacache{$uri.':'.$unikey.'.part'}=$part; |
|
| $metathesekeys{$unikey}=1; |
|
| } |
|
| unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
| $metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
$metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
| } |
} |
|
Line 3663 sub gettitle {
|
Line 3885 sub gettitle {
|
| unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
| return &metadata($urlsymb,'title'); |
return &metadata($urlsymb,'title'); |
| } |
} |
| if ($titlecache{$symb}) { |
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
| if (time < ($titlecache{$symb}[1] + 600)) { |
if (defined($cached)) { return $result; } |
| return $titlecache{$symb}[0]; |
my ($map,$resid,$url)=&decode_symb($symb); |
| } else { |
|
| delete($titlecache{$symb}); |
|
| } |
|
| } |
|
| my ($map,$resid,$url)=split(/\_\_\_/,$symb); |
|
| my $title=''; |
my $title=''; |
| my %bighash; |
my %bighash; |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
|
Line 3681 sub gettitle {
|
Line 3898 sub gettitle {
|
| } |
} |
| $title=~s/\&colon\;/\:/gs; |
$title=~s/\&colon\;/\:/gs; |
| if ($title) { |
if ($title) { |
| $titlecache{$symb}=[$title,time]; |
return &do_cache(\%titlecache,$symb,$title,'title'); |
| return $title; |
|
| } else { |
} else { |
| return &metadata($urlsymb,'title'); |
return &metadata($urlsymb,'title'); |
| } |
} |
|
Line 3716 sub symbverify {
|
Line 3932 sub symbverify {
|
| # direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
| if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
| # check URL part |
# check URL part |
| my ($map,$resid,$url)=split(/\_\_\_/,$symb); |
my ($map,$resid,$url)=&decode_symb($symb); |
| unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } |
unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } |
| |
|
| $symb=&symbclean($symb); |
$symb=&symbclean($symb); |
|
Line 3759 sub symbclean {
|
Line 3975 sub symbclean {
|
| return $symb; |
return $symb; |
| } |
} |
| |
|
| |
# ---------------------------------------------- Split symb to find map and url |
| |
|
| |
sub decode_symb { |
| |
my ($map,$resid,$url)=split(/\_\_\_/,shift); |
| |
return (&fixversion($map),$resid,&fixversion($url)); |
| |
} |
| |
|
| |
sub fixversion { |
| |
my $fn=shift; |
| |
if ($fn=~/^(adm|uploaded|public)/) { return $fn; } |
| |
my ($match,$cond,$versioned)=&is_on_map($fn); |
| |
unless ($match) { |
| |
$fn=$versioned; |
| |
} |
| |
return $fn; |
| |
} |
| |
|
| # ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
| |
|
| sub symbread { |
sub symbread { |
|
Line 4058 sub unescape {
|
Line 4291 sub unescape {
|
| return $str; |
return $str; |
| } |
} |
| |
|
| |
sub mod_perl_version { |
| |
if (defined($perlvar{'MODPERL2'})) { |
| |
return 2; |
| |
} |
| |
return 1; |
| |
} |
| # ================================================================ Main Program |
# ================================================================ Main Program |
| |
|
| sub goodbye { |
sub goodbye { |
| &logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
| |
#not converted to using infrastruture |
| |
&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); |
| |
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
| |
&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
| |
#converted |
| |
&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
| |
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
| |
#1.1 only |
| |
&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); |
| |
&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); |
| &flushcourselogs(); |
&flushcourselogs(); |
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| return DONE; |
return DONE; |
|
Line 4105 BEGIN {
|
Line 4354 BEGIN {
|
| next if (/^(\#|\s*$)/); |
next if (/^(\#|\s*$)/); |
| # next if /^\#/; |
# next if /^\#/; |
| chomp; |
chomp; |
| my ($domain, $domain_description, $def_auth, $def_auth_arg) |
my ($domain, $domain_description, $def_auth, $def_auth_arg, |
| = split(/:/,$_,4); |
$def_lang, $city, $longi, $lati) = split(/:/,$_); |
| $domain_auth_def{$domain}=$def_auth; |
$domain_auth_def{$domain}=$def_auth; |
| $domain_auth_arg_def{$domain}=$def_auth_arg; |
$domain_auth_arg_def{$domain}=$def_auth_arg; |
| $domaindescription{$domain}=$domain_description; |
$domaindescription{$domain}=$domain_description; |
| |
$domain_lang_def{$domain}=$def_lang; |
| |
$domain_city{$domain}=$city; |
| |
$domain_longi{$domain}=$longi; |
| |
$domain_lati{$domain}=$lati; |
| |
|
| # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
| # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
| } |
} |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl