version 1.195, 2001/12/28 19:48:42
|
version 1.213, 2002/05/07 19:16:15
|
Line 65
|
Line 65
|
# 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 |
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer |
|
# YEAR=2002 |
|
# 1/4,2/4,2/7 Gerd Kortemeyer |
# |
# |
### |
### |
|
|
Line 78 use vars
|
Line 80 use vars
|
qw(%perlvar %hostname %homecache %hostip %spareid %hostdom |
qw(%perlvar %hostname %homecache %hostip %spareid %hostdom |
%libserv %pr %prp %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; |
my $readit; |
|
|
Line 135 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 346 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 389 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 638 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 662 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 859 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 872 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 1009 sub store {
|
Line 1139 sub store {
|
|
|
if ($stuname) { $home=&homeserver($stuname,$domain); } |
if ($stuname) { $home=&homeserver($stuname,$domain); } |
|
|
|
$symb=&symbclean($symb); |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
|
|
&devalidate($symb); |
&devalidate($symb); |
Line 1039 sub cstore {
|
Line 1170 sub cstore {
|
|
|
if ($stuname) { $home=&homeserver($stuname,$domain); } |
if ($stuname) { $home=&homeserver($stuname,$domain); } |
|
|
|
$symb=&symbclean($symb); |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
|
|
&devalidate($symb); |
&devalidate($symb); |
Line 1074 sub restore {
|
Line 1206 sub restore {
|
if (!$symb) { |
if (!$symb) { |
unless ($symb=escape(&symbread())) { return ''; } |
unless ($symb=escape(&symbread())) { return ''; } |
} else { |
} else { |
$symb=&escape($symb); |
$symb=&escape(&symbclean($symb)); |
} |
} |
if (!$namespace) { |
if (!$namespace) { |
unless ($namespace=$ENV{'request.course.id'}) { |
unless ($namespace=$ENV{'request.course.id'}) { |
Line 1704 sub assignrole {
|
Line 1836 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 1719 sub modifyuserauth {
|
Line 1862 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 1746 sub modifyuser {
|
Line 1897 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 1757 sub modifyuser {
|
Line 1909 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 1774 sub modifyuser {
|
Line 1927 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 1791 sub modifyuser {
|
Line 1945 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 2006 sub condval {
|
Line 2161 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 2126 sub EXT {
|
Line 2313 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 2220 sub metadata {
|
Line 2392 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 2309 sub metadata {
|
Line 2481 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 2347 sub symblist {
|
Line 2519 sub symblist {
|
return 'error'; |
return 'error'; |
} |
} |
|
|
|
# --------------------------------------------------------------- Verify a symb |
|
|
|
sub symbverify { |
|
my ($symb,$thisfn)=@_; |
|
$thisfn=&declutter($thisfn); |
|
|
|
# &logthis("Symb verify: $symb $thisfn"); |
|
|
|
my ($map,$resid,$url)=split(/\_\_\_/,$symb); |
|
unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } |
|
|
|
return 1; |
|
|
|
my %bighash; |
|
my $okay=0; |
|
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
|
&GDBM_READER,0640)) { |
|
|
|
untie(%bighash); |
|
} |
|
return $okay; |
|
} |
|
|
|
# --------------------------------------------------------------- Clean-up symb |
|
|
|
sub symbclean { |
|
my $symb=shift; |
|
|
|
# &logthis("Symb in: $symb"); |
|
|
|
# remove version from map |
|
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; |
|
# remove version from URL |
|
$symb=~s/\.(\d+)\.(\w+)$/\.$2/; |
|
|
|
# &logthis("Symb out: $symb"); |
|
|
|
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 2411 sub symbread {
|
Line 2623 sub symbread {
|
} |
} |
} |
} |
if ($syval) { |
if ($syval) { |
return $syval.'___'.$thisfn; |
return &symbclean($syval.'___'.$thisfn); |
} |
} |
} |
} |
&appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
Line 2550 sub unescape {
|
Line 2762 sub unescape {
|
# ================================================================ Main Program |
# ================================================================ Main Program |
|
|
sub goodbye { |
sub goodbye { |
|
&logthis("Starting Shut down"); |
&flushcourselogs(); |
&flushcourselogs(); |
&logthis("Shutting down"); |
&logthis("Shutting down"); |
} |
} |
Line 2812 devalidate($symb) : devalidate spreadshe
|
Line 3025 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 * |
|
|