--- loncom/lonnet/perl/lonnet.pm 2001/12/18 20:59:38 1.191 +++ loncom/lonnet/perl/lonnet.pm 2002/05/13 09:32:56 1.219 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.191 2001/12/18 20:59:38 harris41 Exp $ +# $Id: lonnet.pm,v 1.219 2002/05/13 09:32:56 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -64,6 +64,9 @@ # 12/5 Guy Albertelli # 12/6,12/7,12/12 Gerd Kortemeyer # 12/18 Scott Harrison +# 12/21,12/22,12/27,12/28 Gerd Kortemeyer +# YEAR=2002 +# 1/4,2/4,2/7 Gerd Kortemeyer # ### @@ -75,14 +78,15 @@ use LWP::UserAgent(); use HTTP::Headers; use vars qw(%perlvar %hostname %homecache %hostip %spareid %hostdom - %libserv %pr %prp %fe %fd %metacache %packagetab + %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; # --------------------------------------------------------------------- Logging @@ -133,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"); @@ -344,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 { @@ -387,6 +442,7 @@ sub queryauthenticate { sub authenticate { my ($uname,$upass,$udom)=@_; $upass=escape($upass); + $uname=~s/\W//g; if (($perlvar{'lonRole'} eq 'library') && ($udom eq $perlvar{'lonDefDomain'})) { my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); @@ -571,6 +627,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); @@ -636,7 +693,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); } @@ -708,7 +765,7 @@ sub courseacclog { my $fnsymb=shift; unless ($ENV{'request.course.id'}) { return ''; } 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'; foreach (keys %ENV) { if ($_=~/^form\.(.*)/) { @@ -857,10 +914,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; } @@ -870,9 +972,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 @@ -1007,6 +1139,7 @@ sub store { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1037,6 +1170,7 @@ sub cstore { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1072,7 +1206,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'}) { @@ -1273,11 +1407,16 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { - my ($namespace,$udomain,$uname)=@_; + my ($namespace,$udomain,$uname,$regexp)=@_; if (!$udomain) { $udomain=$ENV{'user.domain'}; } if (!$uname) { $uname=$ENV{'user.name'}; } 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 %returnhash=(); foreach (@pairs) { @@ -1548,7 +1687,7 @@ sub allowed { if ($thisallowed=~/C/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} - =~/\,$rolecode\,/) { + =~/$rolecode/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $ENV{'request.course.id'}); @@ -1697,14 +1836,25 @@ sub assignrole { } # -------------------------------------------------- Modify user authentication +# Overrides without validation + sub modifyuserauth { my ($udom,$uname,$umode,$upass)=@_; 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'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &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') { + &logthis('Authentication mode error: '.$reply); return 'error: '.$reply; } return 'ok'; @@ -1712,20 +1862,28 @@ sub modifyuserauth { # --------------------------------------------------------------- Modify a user - 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.', '. $umode.', '.$first.', '.$middle.', '. - $last.', '.$gene.' by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $last.', '.$gene.'(forceid: '.$forceid.')'. + (defined($desiredhome) ? ' desiredhome = '.$desiredhome : + ' desiredhome not specified'). + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); my $uhome=&homeserver($uname,$udom); # ----------------------------------------------------------------- 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) { @@ -1739,7 +1897,8 @@ 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); @@ -1750,12 +1909,13 @@ sub modifyuser { 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/; my %uidhash=&idrget($udom,$uname); - if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) { + if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) + && (!$forceid)) { unless ($uid eq $uidhash{$uname}) { return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; } @@ -1767,6 +1927,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; } @@ -1784,14 +1945,15 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start)=@_; + $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); + ($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')) { @@ -1999,11 +2161,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]) { @@ -2018,19 +2223,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; @@ -2039,10 +2253,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; @@ -2059,127 +2273,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') { @@ -2213,7 +2412,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) { @@ -2302,7 +2501,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'}; } @@ -2340,12 +2539,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); @@ -2404,7 +2654,7 @@ sub symbread { } } if ($syval) { - return $syval.'___'.$thisfn; + return &symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); @@ -2543,17 +2793,32 @@ sub unescape { # ================================================================ Main Program sub goodbye { + &logthis("Starting Shut down"); &flushcourselogs(); &logthis("Shutting down"); } BEGIN { -# ------------------------------------------------------------ Read access.conf +# ------------------------------------------- Read access.conf and loncapa.conf +# (eventually access.conf will become deprecated) + unless ($readit) { + { my $config=Apache::File->new("/etc/httpd/conf/access.conf"); while (my $configline=<$config>) { - if ($configline =~ /PerlSetVar/) { + if ($configline =~ /^[^\#]*PerlSetVar/) { + my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); + $perlvar{$varname}=$varvalue; + } + } +} +{ + 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; @@ -2627,21 +2892,6 @@ 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=(); $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; @@ -2649,6 +2899,8 @@ $dumpcount=0; &logtouch(); &logthis('INFO: Read configuration'); +$readit=1; +} } 1; @@ -2817,12 +3069,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 * @@ -2869,8 +3139,9 @@ namesp ($udomain and $uname are optional =item * -dump($namespace,$udomain,$uname) : dumps the complete namespace into a hash -($udomain and $uname are optional) +dump($namespace,$udomain,$uname,$regexp) : +dumps the complete (or key matching regexp) namespace into a hash +($udomain, $uname and $regexp are optional) =item *