--- loncom/lonnet/perl/lonnet.pm 2002/02/04 15:31:22 1.199
+++ loncom/lonnet/perl/lonnet.pm 2002/04/04 20:06:20 1.206
@@ -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.206 2002/04/04 20:06:20 matthew 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
#
###
@@ -80,7 +80,7 @@ use vars
qw(%perlvar %hostname %homecache %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);
@@ -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("<font color=blue>WARNING:".
" $cmd to $server returned $answer</font>");
@@ -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 {
@@ -641,7 +692,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);
}
@@ -665,6 +716,7 @@ 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') {
@@ -862,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;
}
@@ -875,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
@@ -1733,22 +1860,27 @@ 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) {
$unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
+ } elsif (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
+ $unhome = $desiredhome;
} else {
my $tryserver;
my $loadm=10000000;
@@ -1763,7 +1895,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);
@@ -2024,6 +2157,38 @@ 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 {
@@ -2144,28 +2309,13 @@ sub EXT {
# -------------------------------------------------------- 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("<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>");
- }
+ my $coursereply=&courseresdata(
+ $ENV{'course.'.$ENV{'request.course.id'}.'.num'},
+ $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
+ ($seclevelr,$seclevelm,$seclevel,
+ $courselevelr,$courselevelm,$courselevel));
+ if ($coursereply) { return $coursereply; }
+
# ------------------------------------------------------ third, check map parms
my %parmhash=();
my $thisparm='';
@@ -2568,6 +2718,7 @@ sub unescape {
# ================================================================ Main Program
sub goodbye {
+ &logthis("Starting Shut down");
&flushcourselogs();
&logthis("Shutting down");
}
@@ -2830,12 +2981,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 *