--- loncom/lonnet/perl/lonnet.pm 2001/12/18 20:59:38 1.191
+++ loncom/lonnet/perl/lonnet.pm 2002/02/04 15:31:22 1.199
@@ -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.199 2002/02/04 15:31:22 www 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 Gerd Kortemeyer
#
###
@@ -75,7 +78,7 @@ 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);
use IO::Socket;
@@ -83,6 +86,7 @@ use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::TokeParser;
use Fcntl qw(:flock);
+my $readit;
# --------------------------------------------------------------------- Logging
@@ -387,6 +391,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'});
@@ -708,7 +713,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\.(.*)/) {
@@ -1273,11 +1278,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 +1558,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 +1707,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';
@@ -1714,10 +1735,13 @@ sub modifyuserauth {
sub modifyuser {
- my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
+ my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
+ $forceid)=@_;
+ $udom=~s/\W//g;
+ $uname=~s/\W//g;
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.' by '.
+ $last.', '.$gene.'(forceid: '.$forceid.') by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});
my $uhome=&homeserver($uname,$udom);
# ----------------------------------------------------------------- Create User
@@ -1755,7 +1779,8 @@ sub modifyuser {
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;
}
@@ -1784,14 +1809,14 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
- $end,$start)=@_;
+ $end,$start,$forceid)=@_;
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);
unless ($reply eq 'ok') { return $reply; }
my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
@@ -2549,6 +2574,7 @@ sub goodbye {
BEGIN {
# ------------------------------------------------------------ Read access.conf
+ unless ($readit) {
{
my $config=Apache::File->new("/etc/httpd/conf/access.conf");
@@ -2627,21 +2653,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 +2660,8 @@ $dumpcount=0;
&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');
+$readit=1;
+}
}
1;
@@ -2869,8 +2882,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 *