--- loncom/lonnet/perl/lonnet.pm 2002/03/29 18:23:50 1.204 +++ loncom/lonnet/perl/lonnet.pm 2002/05/08 14:37:14 1.214 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.204 2002/03/29 18:23:50 albertel Exp $ +# $Id: lonnet.pm,v 1.214 2002/05/08 14:37:14 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -84,7 +84,7 @@ qw(%perlvar %hostname %homecache %hostip 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,6 +137,7 @@ 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') { sleep 5; @@ -626,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); @@ -715,7 +717,6 @@ sub flushcourselogs { &logthis('Flushing course log buffers'); foreach (keys %courselogs) { my $crsid=$_; - &logthis(":$crsid:$coursehombuf{$crsid}"); if (&reply('log:'.$coursedombuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { @@ -1138,6 +1139,7 @@ sub store { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1168,6 +1170,7 @@ sub cstore { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1203,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'}) { @@ -1859,23 +1862,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'}); + $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) { @@ -1889,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); @@ -1900,7 +1909,7 @@ 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/; @@ -1918,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; } @@ -1935,14 +1945,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')) { @@ -2381,7 +2392,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) { @@ -2470,7 +2481,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'}; } @@ -2508,12 +2519,52 @@ sub symblist { 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 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); @@ -2572,7 +2623,7 @@ sub symbread { } } if ($syval) { - return $syval.'___'.$thisfn; + return &symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn);