version 1.191, 2001/12/18 20:59:38
|
version 1.211, 2002/05/06 13:46:41
|
Line 64
|
Line 64
|
# 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/18 Scott Harrison |
|
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer |
|
# YEAR=2002 |
|
# 1/4,2/4,2/7 Gerd Kortemeyer |
# |
# |
### |
### |
|
|
Line 75 use LWP::UserAgent();
|
Line 78 use LWP::UserAgent();
|
use HTTP::Headers; |
use HTTP::Headers; |
use vars |
use vars |
qw(%perlvar %hostname %homecache %hostip %spareid %hostdom |
qw(%perlvar %hostname %homecache %hostip %spareid %hostdom |
%libserv %pr %prp %fe %fd %metacache %packagetab |
%libserv %pr %prp %metacache %packagetab |
%courselogs %accesshash $processmarker $dumpcount |
%courselogs %accesshash $processmarker $dumpcount |
%coursedombuf %coursehombuf); |
%coursedombuf %coursehombuf %courseresdatacache); |
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::TokeParser; |
use HTML::LCParser; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
|
my $readit; |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
|
Line 133 sub subreply {
|
Line 137 sub subreply {
|
|
|
sub reply { |
sub reply { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
|
unless (defined($hostname{$server})) { return 'no_such_host'; } |
my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } |
if ($answer eq 'con_lost') { |
|
sleep 5; |
|
$answer=subreply($cmd,$server); |
|
if ($answer eq 'con_lost') { |
|
&logthis("Second attempt con_lost on $server"); |
|
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
|
my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
|
Type => SOCK_STREAM, |
|
Timeout => 10) |
|
or return "con_lost"; |
|
&logthis("Killing socket"); |
|
print $client "close_connection_exit\n"; |
|
sleep 5; |
|
$answer=subreply($cmd,$server); |
|
} |
|
} |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
&logthis("<font color=blue>WARNING:". |
&logthis("<font color=blue>WARNING:". |
" $cmd to $server returned $answer</font>"); |
" $cmd to $server returned $answer</font>"); |
Line 344 sub spareserver {
|
Line 364 sub spareserver {
|
return $spareserver; |
return $spareserver; |
} |
} |
|
|
|
# --------------------------------------------- Try to change a user's password |
|
|
|
sub changepass { |
|
my ($uname,$udom,$currentpass,$newpass,$server)=@_; |
|
$currentpass = &escape($currentpass); |
|
$newpass = &escape($newpass); |
|
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", |
|
$server); |
|
if (! $answer) { |
|
&logthis("No reply on password change request to $server ". |
|
"by $uname in domain $udom."); |
|
} elsif ($answer =~ "^ok") { |
|
&logthis("$uname in $udom successfully changed their password ". |
|
"on $server."); |
|
} elsif ($answer =~ "^pwchange_failure") { |
|
&logthis("$uname in $udom was unable to change their password ". |
|
"on $server. The action was blocked by either lcpasswd ". |
|
"or pwchange"); |
|
} elsif ($answer =~ "^non_authorized") { |
|
&logthis("$uname in $udom did not get their password correct when ". |
|
"attempting to change it on $server."); |
|
} elsif ($answer =~ "^auth_mode_error") { |
|
&logthis("$uname in $udom attempted to change their password despite ". |
|
"not being locally or internally authenticated on $server."); |
|
} elsif ($answer =~ "^unknown_user") { |
|
&logthis("$uname in $udom attempted to change their password ". |
|
"on $server but were unable to because $server is not ". |
|
"their home server."); |
|
} elsif ($answer =~ "^refused") { |
|
&logthis("$server refused to change $uname in $udom password because ". |
|
"it was sent an unencrypted request to change the password."); |
|
} |
|
return $answer; |
|
} |
|
|
# ----------------------- Try to determine user's current authentication scheme |
# ----------------------- Try to determine user's current authentication scheme |
|
|
sub queryauthenticate { |
sub queryauthenticate { |
Line 387 sub queryauthenticate {
|
Line 442 sub queryauthenticate {
|
sub authenticate { |
sub authenticate { |
my ($uname,$upass,$udom)=@_; |
my ($uname,$upass,$udom)=@_; |
$upass=escape($upass); |
$upass=escape($upass); |
|
$uname=~s/\W//g; |
if (($perlvar{'lonRole'} eq 'library') && |
if (($perlvar{'lonRole'} eq 'library') && |
($udom eq $perlvar{'lonDefDomain'})) { |
($udom eq $perlvar{'lonDefDomain'})) { |
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); |
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); |
Line 636 sub ssi {
|
Line 692 sub ssi {
|
|
|
if (%form) { |
if (%form) { |
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request->content(join '&', map { "$_=$form{$_}" } keys %form); |
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
} else { |
} else { |
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); |
} |
} |
Line 660 sub flushcourselogs {
|
Line 716 sub flushcourselogs {
|
&logthis('Flushing course log buffers'); |
&logthis('Flushing course log buffers'); |
foreach (keys %courselogs) { |
foreach (keys %courselogs) { |
my $crsid=$_; |
my $crsid=$_; |
|
&logthis(":$crsid:$coursehombuf{$crsid}"); |
if (&reply('log:'.$coursedombuf{$crsid}.':'. |
if (&reply('log:'.$coursedombuf{$crsid}.':'. |
&escape($courselogs{$crsid}), |
&escape($courselogs{$crsid}), |
$coursehombuf{$crsid}) eq 'ok') { |
$coursehombuf{$crsid}) eq 'ok') { |
Line 708 sub courseacclog {
|
Line 765 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 ($what=~/(problem|exam|quiz|assess|survey|form)$/) { |
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) { |
$what.=':POST'; |
$what.=':POST'; |
foreach (keys %ENV) { |
foreach (keys %ENV) { |
if ($_=~/^form\.(.*)/) { |
if ($_=~/^form\.(.*)/) { |
Line 857 sub devalidate {
|
Line 914 sub devalidate {
|
} |
} |
} |
} |
|
|
|
sub arrayref2str { |
|
my ($arrayref) = @_; |
|
my $result='_ARRAY_REF__'; |
|
foreach my $elem (@$arrayref) { |
|
if (ref($elem) eq 'ARRAY') { |
|
$result.=&escape(&arrayref2str($elem)).'&'; |
|
} elsif (ref($elem) eq 'HASH') { |
|
$result.=&escape(&hashref2str($elem)).'&'; |
|
} elsif (ref($elem)) { |
|
&logthis("Got a ref of ".(ref($elem))." skipping."); |
|
} else { |
|
$result.=&escape($elem).'&'; |
|
} |
|
} |
|
$result=~s/\&$//; |
|
return $result; |
|
} |
|
|
sub hash2str { |
sub hash2str { |
my (%hash)=@_; |
my (%hash) = @_; |
my $result=''; |
my $result=&hashref2str(\%hash); |
foreach (keys %hash) { $result.=escape($_).'='.escape($hash{$_}).'&'; } |
$result=~s/^_HASH_REF__//; |
|
return $result; |
|
} |
|
|
|
sub hashref2str { |
|
my ($hashref)=@_; |
|
my $result='_HASH_REF__'; |
|
foreach (keys(%$hashref)) { |
|
if (ref($_) eq 'ARRAY') { |
|
$result.=&escape(&arrayref2str($_)).'='; |
|
} elsif (ref($_) eq 'HASH') { |
|
$result.=&escape(&hashref2str($_)).'='; |
|
} elsif (ref($_)) { |
|
&logthis("Got a ref of ".(ref($_))." skipping."); |
|
} else { |
|
$result.=&escape($_).'='; |
|
} |
|
|
|
if (ref($$hashref{$_}) eq 'ARRAY') { |
|
$result.=&escape(&arrayref2str($$hashref{$_})).'&'; |
|
} elsif (ref($$hashref{$_}) eq 'HASH') { |
|
$result.=&escape(&hashref2str($$hashref{$_})).'&'; |
|
} elsif (ref($$hashref{$_})) { |
|
&logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); |
|
} else { |
|
$result.=&escape($$hashref{$_}).'&'; |
|
} |
|
} |
$result=~s/\&$//; |
$result=~s/\&$//; |
return $result; |
return $result; |
} |
} |
Line 870 sub str2hash {
|
Line 972 sub str2hash {
|
my %returnhash; |
my %returnhash; |
foreach (split(/\&/,$string)) { |
foreach (split(/\&/,$string)) { |
my ($name,$value)=split(/\=/,$_); |
my ($name,$value)=split(/\=/,$_); |
$returnhash{&unescape($name)}=&unescape($value); |
$name=&unescape($name); |
|
$value=&unescape($value); |
|
if ($value =~ /^_HASH_REF__/) { |
|
$value =~ s/^_HASH_REF__//; |
|
my %hash=&str2hash($value); |
|
$value=\%hash; |
|
} elsif ($value =~ /^_ARRAY_REF__/) { |
|
$value =~ s/^_ARRAY_REF__//; |
|
my @array=&str2array($value); |
|
$value=\@array; |
|
} |
|
$returnhash{$name}=$value; |
} |
} |
return %returnhash; |
return (%returnhash); |
|
} |
|
|
|
sub str2array { |
|
my ($string) = @_; |
|
my @returnarray; |
|
foreach my $value (split(/\&/,$string)) { |
|
$value=&unescape($value); |
|
if ($value =~ /^_HASH_REF__/) { |
|
$value =~ s/^_HASH_REF__//; |
|
my %hash=&str2hash($value); |
|
$value=\%hash; |
|
} elsif ($value =~ /^_ARRAY_REF__/) { |
|
$value =~ s/^_ARRAY_REF__//; |
|
my @array=&str2array($value); |
|
$value=\@array; |
|
} |
|
push(@returnarray,$value); |
|
} |
|
return (@returnarray); |
} |
} |
|
|
# -------------------------------------------------------------------Temp Store |
# -------------------------------------------------------------------Temp Store |
Line 1273 sub del {
|
Line 1405 sub del {
|
# -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
|
|
sub dump { |
sub dump { |
my ($namespace,$udomain,$uname)=@_; |
my ($namespace,$udomain,$uname,$regexp)=@_; |
if (!$udomain) { $udomain=$ENV{'user.domain'}; } |
if (!$udomain) { $udomain=$ENV{'user.domain'}; } |
if (!$uname) { $uname=$ENV{'user.name'}; } |
if (!$uname) { $uname=$ENV{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
my $rep=reply("dump:$udomain:$uname:$namespace",$uhome); |
if ($regexp) { |
|
$regexp=&escape($regexp); |
|
} else { |
|
$regexp='.'; |
|
} |
|
my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
my %returnhash=(); |
my %returnhash=(); |
foreach (@pairs) { |
foreach (@pairs) { |
Line 1548 sub allowed {
|
Line 1685 sub allowed {
|
if ($thisallowed=~/C/) { |
if ($thisallowed=~/C/) { |
my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} |
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} |
=~/\,$rolecode\,/) { |
=~/$rolecode/) { |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
$ENV{'request.course.id'}); |
$ENV{'request.course.id'}); |
Line 1697 sub assignrole {
|
Line 1834 sub assignrole {
|
} |
} |
|
|
# -------------------------------------------------- Modify user authentication |
# -------------------------------------------------- Modify user authentication |
|
# Overrides without validation |
|
|
sub modifyuserauth { |
sub modifyuserauth { |
my ($udom,$uname,$umode,$upass)=@_; |
my ($udom,$uname,$umode,$upass)=@_; |
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
&logthis('Call to modify user authentication'.$udom.', '.$uname.', '. |
unless (&allowed('mau',$udom)) { return 'refused'; } |
|
&logthis('Call to modify user authentication '.$udom.', '.$uname.', '. |
$umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
$umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. |
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. |
&escape($upass),$uhome); |
&escape($upass),$uhome); |
|
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, |
|
'Authentication changed for '.$udom.', '.$uname.', '.$umode. |
|
'(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); |
|
&log($udom,,$uname,$uhome, |
|
'Authentication changed by '.$ENV{'user.domain'}.', '. |
|
$ENV{'user.name'}.', '.$umode. |
|
'(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); |
unless ($reply eq 'ok') { |
unless ($reply eq 'ok') { |
|
&logthis('Authentication mode error: '.$reply); |
return 'error: '.$reply; |
return 'error: '.$reply; |
} |
} |
return 'ok'; |
return 'ok'; |
Line 1712 sub modifyuserauth {
|
Line 1860 sub modifyuserauth {
|
|
|
# --------------------------------------------------------------- Modify a user |
# --------------------------------------------------------------- Modify a user |
|
|
|
|
sub modifyuser { |
sub modifyuser { |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_; |
my ($udom, $uname, $uid, |
|
$umode, $upass, $first, |
|
$middle, $last, $gene, |
|
$forceid, $desiredhome)=@_; |
|
$udom=~s/\W//g; |
|
$uname=~s/\W//g; |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
$umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
$last.', '.$gene.' by '. |
$last.', '.$gene.'(forceid: '.$forceid.')'. |
$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
|
' desiredhome not specified'). |
|
' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
# ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
my $unhome=''; |
my $unhome=''; |
if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { |
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
|
$unhome = $desiredhome; |
|
} elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { |
$unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
$unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
} else { |
} else { # load balancing routine for determining $unhome |
my $tryserver; |
my $tryserver; |
my $loadm=10000000; |
my $loadm=10000000; |
foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
Line 1739 sub modifyuser {
|
Line 1895 sub modifyuser {
|
} |
} |
} |
} |
if (($unhome eq '') || ($unhome eq 'no_host')) { |
if (($unhome eq '') || ($unhome eq 'no_host')) { |
return 'error: find home'; |
return 'error: unable to find a home server for '.$uname. |
|
' in domain '.$udom; |
} |
} |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. |
&escape($upass),$unhome); |
&escape($upass),$unhome); |
Line 1750 sub modifyuser {
|
Line 1907 sub modifyuser {
|
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
return 'error: verify home'; |
return 'error: verify home'; |
} |
} |
} |
} # End of creation of new user |
# ---------------------------------------------------------------------- Add ID |
# ---------------------------------------------------------------------- Add ID |
if ($uid) { |
if ($uid) { |
$uid=~tr/A-Z/a-z/; |
$uid=~tr/A-Z/a-z/; |
my %uidhash=&idrget($udom,$uname); |
my %uidhash=&idrget($udom,$uname); |
if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) { |
if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) |
|
&& (!$forceid)) { |
unless ($uid eq $uidhash{$uname}) { |
unless ($uid eq $uidhash{$uname}) { |
return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; |
return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; |
} |
} |
Line 1767 sub modifyuser {
|
Line 1925 sub modifyuser {
|
my %names=&get('environment', |
my %names=&get('environment', |
['firstname','middlename','lastname','generation'], |
['firstname','middlename','lastname','generation'], |
$udom,$uname); |
$udom,$uname); |
|
if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } |
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 1784 sub modifyuser {
|
Line 1943 sub modifyuser {
|
|
|
sub modifystudent { |
sub modifystudent { |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
$end,$start)=@_; |
$end,$start,$forceid,$desiredhome)=@_; |
my $cid=''; |
my $cid=''; |
unless ($cid=$ENV{'request.course.id'}) { |
unless ($cid=$ENV{'request.course.id'}) { |
return 'not_in_class'; |
return 'not_in_class'; |
} |
} |
# --------------------------------------------------------------- Make the user |
# --------------------------------------------------------------- Make the user |
my $reply=&modifyuser |
my $reply=&modifyuser |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene); |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
|
$desiredhome); |
unless ($reply eq 'ok') { return $reply; } |
unless ($reply eq 'ok') { return $reply; } |
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
Line 1999 sub condval {
|
Line 2159 sub condval {
|
return $result; |
return $result; |
} |
} |
|
|
|
# --------------------------------------------------- Course Resourcedata Query |
|
|
|
sub courseresdata { |
|
my ($coursenum,$coursedomain,@which)=@_; |
|
my $coursehom=&homeserver($coursenum,$coursedomain); |
|
my $hashid=$coursenum.':'.$coursedomain; |
|
unless (defined($courseresdatacache{$hashid.'.time'})) { |
|
unless (time-$courseresdatacache{$hashid.'.time'}<300) { |
|
my $coursehom=&homeserver($coursenum,$coursedomain); |
|
if ($coursehom) { |
|
my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum. |
|
':resourcedata:.',$coursehom); |
|
unless ($dumpreply=~/^error\:/) { |
|
$courseresdatacache{$hashid.'.time'}=time; |
|
$courseresdatacache{$hashid}=$dumpreply; |
|
} |
|
} |
|
} |
|
} |
|
my @pairs=split(/\&/,$courseresdatacache{$hashid}); |
|
my %returnhash=(); |
|
foreach (@pairs) { |
|
my ($key,$value)=split(/=/,$_); |
|
$returnhash{unescape($key)}=unescape($value); |
|
} |
|
my $item; |
|
foreach $item (@which) { |
|
if ($returnhash{$item}) { return $returnhash{$item}; } |
|
} |
|
return ''; |
|
} |
|
|
# --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
|
|
sub EXT { |
sub EXT { |
Line 2119 sub EXT {
|
Line 2311 sub EXT {
|
|
|
# -------------------------------------------------------- second, check course |
# -------------------------------------------------------- second, check course |
|
|
my $reply=&reply('get:'. |
my $coursereply=&courseresdata( |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'}, |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'}. |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, |
':resourcedata:'. |
($seclevelr,$seclevelm,$seclevel, |
&escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'. |
$courselevelr,$courselevelm,$courselevel)); |
&escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel), |
if ($coursereply) { return $coursereply; } |
$ENV{'course.'.$ENV{'request.course.id'}.'.home'}); |
|
if ($reply!~/^error\:/) { |
|
foreach (split(/\&/,$reply)) { |
|
if ($_) { return &unescape($_); } |
|
} |
|
} |
|
if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) { |
|
&logthis("<font color=blue>WARNING:". |
|
" Getting ".$reply." asking for ".$varname." for ". |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.num'}. |
|
' at '. |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}. |
|
' from '. |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.home'}. |
|
"</font>"); |
|
} |
|
# ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
my %parmhash=(); |
my %parmhash=(); |
my $thisparm=''; |
my $thisparm=''; |
Line 2213 sub metadata {
|
Line 2390 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($perlvar{'lonDocRoot'}.'/res/'.$filename); |
my $parser=HTML::TokeParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
my $token; |
my $token; |
undef %metathesekeys; |
undef %metathesekeys; |
while ($token=$parser->get_token) { |
while ($token=$parser->get_token) { |
Line 2302 sub metadata {
|
Line 2479 sub metadata {
|
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
} |
} |
unless ( |
unless ( |
$metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) |
$metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) |
) { $metacache{$uri.':'.$unikey}= |
) { $metacache{$uri.':'.$unikey}= |
$metacache{$uri.':'.$unikey.'.default'}; |
$metacache{$uri.':'.$unikey.'.default'}; |
} |
} |
Line 2340 sub symblist {
|
Line 2517 sub symblist {
|
return 'error'; |
return 'error'; |
} |
} |
|
|
|
# --------------------------------------------------------------- Clean-up symb |
|
|
|
sub symbclean { |
|
my $symb=shift; |
|
# remove version from map |
|
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; |
|
# remove version from URL |
|
$symb=~s/\.(\d+)\.(\w+)$/\.$2/; |
|
return $symb; |
|
} |
|
|
# ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
|
|
sub symbread { |
sub symbread { |
my $thisfn=shift; |
my $thisfn=shift; |
unless ($thisfn) { |
unless ($thisfn) { |
if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; } |
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } |
$thisfn=$ENV{'request.filename'}; |
$thisfn=$ENV{'request.filename'}; |
} |
} |
$thisfn=declutter($thisfn); |
$thisfn=declutter($thisfn); |
Line 2404 sub symbread {
|
Line 2592 sub symbread {
|
} |
} |
} |
} |
if ($syval) { |
if ($syval) { |
return $syval.'___'.$thisfn; |
return &symbclean($syval.'___'.$thisfn); |
} |
} |
} |
} |
&appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
Line 2543 sub unescape {
|
Line 2731 sub unescape {
|
# ================================================================ Main Program |
# ================================================================ Main Program |
|
|
sub goodbye { |
sub goodbye { |
|
&logthis("Starting Shut down"); |
&flushcourselogs(); |
&flushcourselogs(); |
&logthis("Shutting down"); |
&logthis("Shutting down"); |
} |
} |
|
|
BEGIN { |
BEGIN { |
# ------------------------------------------------------------ Read access.conf |
# ------------------------------------------------------------ Read access.conf |
|
unless ($readit) { |
{ |
{ |
my $config=Apache::File->new("/etc/httpd/conf/access.conf"); |
my $config=Apache::File->new("/etc/httpd/conf/access.conf"); |
|
|
Line 2627 BEGIN {
|
Line 2817 BEGIN {
|
} |
} |
} |
} |
|
|
# ------------------------------------------------------------- Read file types |
|
{ |
|
my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); |
|
|
|
while (my $configline=<$config>) { |
|
next if ($configline =~ /^\#/); |
|
chomp($configline); |
|
my ($ending,$emb,@descr)=split(/\s+/,$configline); |
|
if ($descr[0] ne '') { |
|
$fe{$ending}=lc($emb); |
|
$fd{$ending}=join(' ',@descr); |
|
} |
|
} |
|
} |
|
|
|
%metacache=(); |
%metacache=(); |
|
|
$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; |
Line 2649 $dumpcount=0;
|
Line 2824 $dumpcount=0;
|
|
|
&logtouch(); |
&logtouch(); |
&logthis('<font color=yellow>INFO: Read configuration</font>'); |
&logthis('<font color=yellow>INFO: Read configuration</font>'); |
|
$readit=1; |
|
} |
} |
} |
|
|
1; |
1; |
Line 2817 devalidate($symb) : devalidate spreadshe
|
Line 2994 devalidate($symb) : devalidate spreadshe
|
=item * |
=item * |
|
|
hash2str(%hash) : convert a hash into a string complete with escaping and '=' |
hash2str(%hash) : convert a hash into a string complete with escaping and '=' |
and '&' separators |
and '&' separators, supports elements that are arrayrefs and hashrefs |
|
|
|
=item * |
|
|
|
hashref2str($hashref) : convert a hashref into a string complete with |
|
escaping and '=' and '&' separators, supports elements that are |
|
arrayrefs and hashrefs |
|
|
|
=item * |
|
|
|
arrayref2str($arrayref) : convert an arrayref into a string complete |
|
with escaping and '&' separators, supports elements that are arrayrefs |
|
and hashrefs |
|
|
|
=item * |
|
|
|
str2hash($string) : convert string to hash using unescaping and |
|
splitting on '=' and '&', supports elements that are arrayrefs and |
|
hashrefs |
|
|
=item * |
=item * |
|
|
str2hash($string) : convert string to hash using unescaping and splitting on |
str2array($string) : convert string to hash using unescaping and |
'=' and '&' |
splitting on '&', supports elements that are arrayrefs and hashrefs |
|
|
=item * |
=item * |
|
|
Line 2869 namesp ($udomain and $uname are optional
|
Line 3064 namesp ($udomain and $uname are optional
|
|
|
=item * |
=item * |
|
|
dump($namespace,$udomain,$uname) : dumps the complete namespace into a hash |
dump($namespace,$udomain,$uname,$regexp) : |
($udomain and $uname are optional) |
dumps the complete (or key matching regexp) namespace into a hash |
|
($udomain, $uname and $regexp are optional) |
|
|
=item * |
=item * |
|
|