--- loncom/lonnet/perl/lonnet.pm 2002/02/04 15:31:22 1.199 +++ loncom/lonnet/perl/lonnet.pm 2002/05/22 13:56:43 1.231 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.199 2002/02/04 15:31:22 www Exp $ +# $Id: lonnet.pm,v 1.231 2002/05/22 13:56:43 stredwic Exp $ # # Copyright Michigan State University Board of Trustees # @@ -66,7 +66,7 @@ # 12/18 Scott Harrison # 12/21,12/22,12/27,12/28 Gerd Kortemeyer # YEAR=2002 -# 1/4,2/4 Gerd Kortemeyer +# 1/4,2/4,2/7 Gerd Kortemeyer # ### @@ -77,14 +77,14 @@ use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars -qw(%perlvar %hostname %homecache %hostip %spareid %hostdom +qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom %libserv %pr %prp %metacache %packagetab %courselogs %accesshash $processmarker $dumpcount - %coursedombuf %coursehombuf); + %coursedombuf %coursehombuf %courseresdatacache); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); -use HTML::TokeParser; +use HTML::LCParser; use Fcntl qw(:flock); my $readit; @@ -137,8 +137,24 @@ sub subreply { sub reply { my ($cmd,$server)=@_; + unless (defined($hostname{$server})) { return 'no_such_host'; } 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/)) { &logthis("WARNING:". " $cmd to $server returned $answer"); @@ -348,6 +364,41 @@ sub 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 sub queryauthenticate { @@ -430,19 +481,23 @@ sub authenticate { # ---------------------- Find the homebase for a user from domain's lib servers sub homeserver { - my ($uname,$udom)=@_; - + my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - if ($homecache{$index}) { return "$homecache{$index}"; } - + if ($homecache{$index}) { + return "$homecache{$index}"; + } my $tryserver; foreach $tryserver (keys %libserv) { + next if ($ignoreBadCache ne 'true' && + exists($badServerCache{$tryserver})); if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - $homecache{$index}=$tryserver; + $homecache{$index}=$tryserver; return $tryserver; - } + } elsif ($answer eq 'no_host') { + $badServerCache{$tryserver}=1; + } } } return 'no_host'; @@ -576,6 +631,7 @@ sub subscribe { sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; + if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } my $transname="$filename.in.transfer"; if ((-e $filename) || (-e $transname)) { return OK; } my $remoteurl=subscribe($filename); @@ -641,7 +697,7 @@ sub ssi { if (%form) { $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 { $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); } @@ -862,10 +918,55 @@ 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 { - my (%hash)=@_; - my $result=''; - foreach (keys %hash) { $result.=escape($_).'='.escape($hash{$_}).'&'; } + my (%hash) = @_; + my $result=&hashref2str(\%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/\&$//; return $result; } @@ -875,9 +976,39 @@ sub str2hash { my %returnhash; foreach (split(/\&/,$string)) { 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 @@ -1012,6 +1143,7 @@ sub store { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1042,6 +1174,7 @@ sub cstore { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1077,7 +1210,7 @@ sub restore { if (!$symb) { unless ($symb=escape(&symbread())) { return ''; } } else { - $symb=&escape($symb); + $symb=&escape(&symbclean($symb)); } if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { @@ -1733,23 +1866,28 @@ sub modifyuserauth { # --------------------------------------------------------------- Modify a user - sub modifyuser { - my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene, - $forceid)=@_; + 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.', '. $umode.', '.$first.', '.$middle.', '. - $last.', '.$gene.'(forceid: '.$forceid.') by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); - my $uhome=&homeserver($uname,$udom); + $last.', '.$gene.'(forceid: '.$forceid.')'. + (defined($desiredhome) ? ' desiredhome = '.$desiredhome : + ' desiredhome not specified'). + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && ($umode) && ($upass)) { 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'}; - } else { + } else { # load balancing routine for determining $unhome my $tryserver; my $loadm=10000000; foreach $tryserver (keys %libserv) { @@ -1763,18 +1901,19 @@ sub modifyuser { } } 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.':'. &escape($upass),$unhome); unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { return 'error: verify home'; } - } + } # End of creation of new user # ---------------------------------------------------------------------- Add ID if ($uid) { $uid=~tr/A-Z/a-z/; @@ -1792,6 +1931,7 @@ sub modifyuser { my %names=&get('environment', ['firstname','middlename','lastname','generation'], $udom,$uname); + if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } if ($first) { $names{'firstname'} = $first; } if ($middle) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } @@ -1809,14 +1949,15 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid)=@_; + $end,$start,$forceid,$desiredhome)=@_; my $cid=''; unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; } # --------------------------------------------------------------- Make the user my $reply=&modifyuser - ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid); + ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, + $desiredhome); unless ($reply eq 'ok') { return $reply; } my $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { @@ -1875,11 +2016,11 @@ sub createcourse { my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; # ----------------------------------------------- Make sure that does not exist - my $uhome=&homeserver($uname,$udom); + my $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: unable to generate unique course-ID'; } @@ -1888,7 +2029,7 @@ sub createcourse { my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', $ENV{'user.home'}); unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } @@ -2024,11 +2165,54 @@ sub condval { 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 sub EXT { - my ($varname,$symbparm)=@_; + my ($varname,$symbparm,$udom,$uname)=@_; + unless ($varname) { return ''; } + + #get real user name/domain, courseid and symb + my $courseid; + if (!($uname && $udom)) { + (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + if (!$symbparm) { $symbparm=$cursymb; } + } else { + $courseid=$ENV{'request.course.id'}; + } + my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; if ($therest[0]) { @@ -2043,19 +2227,28 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore(); + my %restored=&restore(undef,undef,$udom,$uname); return $restored{$qualifierrest}; # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { + # FIXME - not supporting calls for a specific user return &allowed($qualifier,$rest); # ------------------------------------------ user.preferences, user.environment } elsif (($space eq 'preferences') || ($space eq 'environment')) { - return $ENV{join('.',('environment',$qualifierrest))}; + if (($uname eq $ENV{'user.name'}) && + ($udom eq $ENV{'user.domain'})) { + return $ENV{join('.',('environment',$qualifierrest))}; + } else { + my %returnhash=&userenvironment($udom,$uname,$qualifierrest); + return $returnhash{$qualifierrest}; + } # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { + # FIXME - not supporting calls for a specific user return $ENV{join('.',('request.course',$qualifier))}; # ------------------------------------------------------------------- user.role } elsif ($space eq 'role') { + # FIXME - not supporting calls for a specific user my ($role,$where)=split(/\./,$ENV{'request.role'}); if ($qualifier eq 'value') { return $role; @@ -2064,10 +2257,10 @@ sub EXT { } # ----------------------------------------------------------------- user.domain } elsif ($space eq 'domain') { - return $ENV{'user.domain'}; + return $udom; # ------------------------------------------------------------------- user.name } elsif ($space eq 'name') { - return $ENV{'user.name'}; + return $uname; # ---------------------------------------------------- Any other user namespace } else { my $item=($rest)?$qualifier.'.'.$rest:$qualifier; @@ -2084,127 +2277,112 @@ sub EXT { } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - return $ENV{'course.'.$ENV{'request.course.id'}.'.'. - $spacequalifierrest}; + return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($ENV{'request.course.id'}) { -# print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; + if ($courseid eq $ENV{'request.course.id'}) { + #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme - my $symbp; - if ($symbparm) { - $symbp=$symbparm; - } else { - $symbp=&symbread(); - } - my $mapp=(split(/\_\_\_/,$symbp))[0]; - - my $symbparm=$symbp.'.'.$spacequalifierrest; - my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - - my $seclevel= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$spacequalifierrest; - my $seclevelr= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$symbparm; - my $seclevelm= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$mapparm; - - my $courselevel= - $ENV{'request.course.id'}.'.'.$spacequalifierrest; - my $courselevelr= - $ENV{'request.course.id'}.'.'.$symbparm; - my $courselevelm= - $ENV{'request.course.id'}.'.'.$mapparm; + if (!$symbparm) { $symbparm=&symbread(); } + my $symbp=$symbparm; + my $mapp=(split(/\_\_\_/,$symbp))[0]; + + my $symbparm=$symbp.'.'.$spacequalifierrest; + my $mapparm=$mapp.'___(all).'.$spacequalifierrest; + + my $section; + if (($ENV{'user.name'} eq $uname) && + ($ENV{'user.domain'} eq $udom)) { + $section={'request.course.sec'}; + } else { + $section=&usection($udom,$uname,$courseid); + } -# ----------------------------------------------------------- first, check user - my %resourcedata=get('resourcedata', - [$courselevelr,$courselevelm,$courselevel]); - if (($resourcedata{$courselevelr}!~/^error\:/) && - ($resourcedata{$courselevelr}!~/^con_lost/)) { - - if ($resourcedata{$courselevelr}) { - return $resourcedata{$courselevelr}; } - if ($resourcedata{$courselevelm}) { - return $resourcedata{$courselevelm}; } - if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; } + my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; + my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; + my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; + + my $courselevel=$courseid.'.'.$spacequalifierrest; + my $courselevelr=$courseid.'.'.$symbparm; + my $courselevelm=$courseid.'.'.$mapparm; - } else { - if ($resourcedata{$courselevelr}!~/No such file/) { - &logthis("WARNING:". - " Trying to get resource data for ".$ENV{'user.name'}." at " - .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}. - ""); - } - } +# ----------------------------------------------------------- first, check user + my %resourcedata=&get('resourcedata', + [$courselevelr,$courselevelm,$courselevel], + $udom,$uname); + if (($resourcedata{$courselevelr}!~/^error\:/) && + ($resourcedata{$courselevelr}!~/^con_lost/)) { + + if ($resourcedata{$courselevelr}) { + return $resourcedata{$courselevelr}; } + if ($resourcedata{$courselevelm}) { + return $resourcedata{$courselevelm}; } + if ($resourcedata{$courselevel}) { + return $resourcedata{$courselevel}; } + } else { + if ($resourcedata{$courselevelr}!~/No such file/) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $resourcedata{$courselevelr}.""); + } + } # -------------------------------------------------------- second, check course - my $reply=&reply('get:'. - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}. - ':resourcedata:'. - &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'. - &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel), - $ENV{'course.'.$ENV{'request.course.id'}.'.home'}); - if ($reply!~/^error\:/) { - foreach (split(/\&/,$reply)) { - if ($_) { return &unescape($_); } - } - } - if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) { - &logthis("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'}. - ""); - } + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr,$courselevelm, + $courselevel)); + if ($coursereply) { return $coursereply; } + # ------------------------------------------------------ third, check map parms - my %parmhash=(); - my $thisparm=''; - if (tie(%parmhash,'GDBM_File', - $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) { - $thisparm=$parmhash{$symbparm}; - untie(%parmhash); - } - if ($thisparm) { return $thisparm; } - } - + my %parmhash=(); + my $thisparm=''; + if (tie(%parmhash,'GDBM_File', + $ENV{'request.course.fn'}.'_parms.db', + &GDBM_READER,0640)) { + $thisparm=$parmhash{$symbparm}; + untie(%parmhash); + } + if ($thisparm) { return $thisparm; } + } # --------------------------------------------- last, look in resource metadata - $spacequalifierrest=~s/\./\_/; - my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); - if ($metadata) { return $metadata; } - $metadata=&metadata($ENV{'request.filename'}, - 'parameter_'.$spacequalifierrest); - if ($metadata) { return $metadata; } + $spacequalifierrest=~s/\./\_/; + my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); + if ($metadata) { return $metadata; } + $metadata=&metadata($ENV{'request.filename'}, + 'parameter_'.$spacequalifierrest); + if ($metadata) { return $metadata; } # ------------------------------------------------------------------ Cascade up - - unless ($space eq '0') { - my ($part,$id)=split(/\_/,$space); - if ($id) { - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm); - if ($partgeneral) { return $partgeneral; } - } else { - my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, - $symbparm); - if ($resourcegeneral) { return $resourcegeneral; } - } - } + unless ($space eq '0') { + my ($part,$id)=split(/\_/,$space); + if ($id) { + my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + $symbparm,$udom,$uname); + if ($partgeneral) { return $partgeneral; } + } else { + my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, + $symbparm,$udom,$uname); + if ($resourcegeneral) { return $resourcegeneral; } + } + } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - return $ENV{'environment.'.$spacequalifierrest}; + if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { + return $ENV{'environment.'.$spacequalifierrest}; + } else { + my %returnhash=&userenvironment($udom,$uname, + $spacequalifierrest); + return $returnhash{$spacequalifierrest}; + } } elsif ($realm eq 'system') { # ----------------------------------------------------------------- system.time if ($space eq 'time') { @@ -2238,7 +2416,7 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); - my $parser=HTML::TokeParser->new(\$metastring); + my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; while ($token=$parser->get_token) { @@ -2327,7 +2505,7 @@ sub metadata { $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; } unless ( - $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) + $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) ) { $metacache{$uri.':'.$unikey}= $metacache{$uri.':'.$unikey.'.default'}; } @@ -2365,12 +2543,63 @@ sub symblist { return 'error'; } +# --------------------------------------------------------------- Verify a symb + +sub symbverify { + my ($symb,$thisfn)=@_; + $thisfn=&declutter($thisfn); +# direct jump to resource in page or to a sequence - will construct own symbs + if ($thisfn=~/\.(page|sequence)$/) { return 1; } +# check URL part + my ($map,$resid,$url)=split(/\_\_\_/,$symb); + unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } + + $symb=&symbclean($symb); + + my %bighash; + my $okay=0; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER,0640)) { + my $ids=$bighash{'ids_/res/'.$thisfn}; + unless ($ids) { + $ids=$bighash{'ids_/'.$thisfn}; + } + if ($ids) { +# ------------------------------------------------------------------- Has ID(s) + foreach (split(/\,/,$ids)) { + my ($mapid,$resid)=split(/\./,$_); + if ( + &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) + eq $symb) { + $okay=1; + } + } + } + untie(%bighash); + } + return $okay; +} + +# --------------------------------------------------------------- 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 sub symbread { my $thisfn=shift; unless ($thisfn) { - if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; } + if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } $thisfn=$ENV{'request.filename'}; } $thisfn=declutter($thisfn); @@ -2429,7 +2658,7 @@ sub symbread { } } if ($syval) { - return $syval.'___'.$thisfn; + return &symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); @@ -2533,6 +2762,7 @@ sub hreflocation { unless (($file=~/^http:\/\//i) || ($file=~/^\//)) { my $finalpath=filelocation($dir,$file); $finalpath=~s/^\/home\/httpd\/html//; + $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; return $finalpath; } else { return $file; @@ -2568,18 +2798,30 @@ sub unescape { # ================================================================ Main Program sub goodbye { + &logthis("Starting Shut down"); &flushcourselogs(); &logthis("Shutting down"); } BEGIN { -# ------------------------------------------------------------ Read access.conf +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { - my $config=Apache::File->new("/etc/httpd/conf/access.conf"); + my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); + + while (my $configline=<$config>) { + if ($configline =~ /^[^\#]*PerlSetVar/) { + my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); + $perlvar{$varname}=$varvalue; + } + } +} +{ + my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); while (my $configline=<$config>) { - if ($configline =~ /PerlSetVar/) { + if ($configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; @@ -2830,12 +3072,30 @@ devalidate($symb) : devalidate spreadshe =item * 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 * -str2hash($string) : convert string to hash using unescaping and splitting on -'=' and '&' +str2array($string) : convert string to hash using unescaping and +splitting on '&', supports elements that are arrayrefs and hashrefs =item * @@ -3030,7 +3290,7 @@ replicates and subscribes to the file =item * filelocation($dir,$file) : returns file system location of a file based on URI; -meant to be "fairly clean" absolute reference +meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob) =item *