version 1.346, 2006/10/23 21:22:38
|
version 1.356, 2007/01/15 01:08:28
|
Line 40 use IO::File;
|
Line 40 use IO::File;
|
use POSIX; |
use POSIX; |
use Crypt::IDEA; |
use Crypt::IDEA; |
use LWP::UserAgent(); |
use LWP::UserAgent(); |
|
use Digest::MD5 qw(md5_hex); |
use GDBM_File; |
use GDBM_File; |
use Authen::Krb4; |
use Authen::Krb4; |
use Authen::Krb5; |
use Authen::Krb5; |
Line 503 sub AdjustHostContents {
|
Line 504 sub AdjustHostContents {
|
my $adjusted; |
my $adjusted; |
my $me = $perlvar{'lonHostID'}; |
my $me = $perlvar{'lonHostID'}; |
|
|
foreach my $line (split(/\n/,$contents)) { |
foreach my $line (split(/\n/,$contents)) { |
if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { |
if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { |
chomp($line); |
chomp($line); |
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); |
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); |
if ($id eq $me) { |
if ($id eq $me) { |
my $ip = gethostbyname($name); |
my $ip = gethostbyname($name); |
my $ipnew = inet_ntoa($ip); |
my $ipnew = inet_ntoa($ip); |
$ip = $ipnew; |
$ip = $ipnew; |
# Reconstruct the host line and append to adjusted: |
# Reconstruct the host line and append to adjusted: |
|
|
my $newline = "$id:$domain:$role:$name:$ip"; |
my $newline = "$id:$domain:$role:$name:$ip"; |
if($maxcon ne "") { # Not all hosts have loncnew tuning params |
if($maxcon ne "") { # Not all hosts have loncnew tuning params |
$newline .= ":$maxcon:$idleto:$mincon"; |
$newline .= ":$maxcon:$idleto:$mincon"; |
} |
} |
$adjusted .= $newline."\n"; |
$adjusted .= $newline."\n"; |
|
|
} else { # Not me, pass unmodified. |
} else { # Not me, pass unmodified. |
$adjusted .= $line."\n"; |
$adjusted .= $line."\n"; |
} |
} |
} else { # Blank or comment never re-written. |
} else { # Blank or comment never re-written. |
$adjusted .= $line."\n"; # Pass blanks and comments as is. |
$adjusted .= $line."\n"; # Pass blanks and comments as is. |
} |
} |
} |
} |
return $adjusted; |
return $adjusted; |
} |
} |
# |
# |
# InstallFile: Called to install an administrative file: |
# InstallFile: Called to install an administrative file: |
Line 3052 sub restore_handler {
|
Line 3053 sub restore_handler {
|
my ($cmd, $tail, $client) = @_; |
my ($cmd, $tail, $client) = @_; |
|
|
my $userinput = "$cmd:$tail"; # Only used for logging purposes. |
my $userinput = "$cmd:$tail"; # Only used for logging purposes. |
|
|
my ($udom,$uname,$namespace,$rid) = split(/:/,$tail); |
my ($udom,$uname,$namespace,$rid) = split(/:/,$tail); |
$namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace = &LONCAPA::clean_username($namespace); |
|
|
chomp($rid); |
chomp($rid); |
my $qresult=''; |
my $qresult=''; |
my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); |
my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); |
Line 3292 sub put_course_id_handler {
|
Line 3293 sub put_course_id_handler {
|
foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$courseinfo) = split(/=/,$pair,2); |
my ($key,$courseinfo) = split(/=/,$pair,2); |
$courseinfo =~ s/=/:/g; |
$courseinfo =~ s/=/:/g; |
|
my @current_items = split(/:/,$hashref->{$key},-1); |
my @current_items = split(/:/,$hashref->{$key}); |
|
shift(@current_items); # remove description |
shift(@current_items); # remove description |
pop(@current_items); # remove last access |
pop(@current_items); # remove last access |
my $numcurrent = scalar(@current_items); |
my $numcurrent = scalar(@current_items); |
|
if ($numcurrent > 3) { |
my @new_items = split(/:/,$courseinfo); |
$numcurrent = 3; |
|
} |
|
my @new_items = split(/:/,$courseinfo,-1); |
my $numnew = scalar(@new_items); |
my $numnew = scalar(@new_items); |
if ($numcurrent > 0) { |
if ($numcurrent > 0) { |
if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 |
if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 |
Line 3509 sub dump_course_id_handler {
|
Line 3511 sub dump_course_id_handler {
|
®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); |
®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); |
|
|
# |
# |
|
# Puts an unencrypted entry in a namespace db file at the domain level |
|
# |
|
# Parameters: |
|
# $cmd - The command that got us here. |
|
# $tail - Tail of the command (remaining parameters). |
|
# $client - File descriptor connected to client. |
|
# Returns |
|
# 0 - Requested to exit, caller should shut down. |
|
# 1 - Continue processing. |
|
# Side effects: |
|
# reply is written to $client. |
|
# |
|
sub put_domain_handler { |
|
my ($cmd,$tail,$client) = @_; |
|
|
|
my $userinput = "$cmd:$tail"; |
|
|
|
my ($udom,$namespace,$what) =split(/:/,$tail,3); |
|
chomp($what); |
|
my @pairs=split(/\&/,$what); |
|
my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(), |
|
"P", $what); |
|
if ($hashref) { |
|
foreach my $pair (@pairs) { |
|
my ($key,$value)=split(/=/,$pair); |
|
$hashref->{$key}=$value; |
|
} |
|
if (&untie_domain_hash($hashref)) { |
|
&Reply($client, "ok\n", $userinput); |
|
} else { |
|
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
|
"while attempting putdom\n", $userinput); |
|
} |
|
} else { |
|
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
|
"while attempting putdom\n", $userinput); |
|
} |
|
|
|
return 1; |
|
} |
|
®ister_handler("putdom", \&put_domain_handler, 0, 1, 0); |
|
|
|
# Unencrypted get from the namespace database file at the domain level. |
|
# This function retrieves a keyed item from a specific named database in the |
|
# domain directory. |
|
# |
|
# Parameters: |
|
# $cmd - Command request keyword (get). |
|
# $tail - Tail of the command. This is a colon separated list |
|
# consisting of the domain and the 'namespace' |
|
# which selects the gdbm file to do the lookup in, |
|
# & separated list of keys to lookup. Note that |
|
# the values are returned as an & separated list too. |
|
# $client - File descriptor open on the client. |
|
# Returns: |
|
# 1 - Continue processing. |
|
# 0 - Exit. |
|
# Side effects: |
|
# reply is written to $client. |
|
# |
|
|
|
sub get_domain_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
|
|
my $userinput = "$client:$tail"; |
|
|
|
my ($udom,$namespace,$what)=split(/:/,$tail,3); |
|
chomp($what); |
|
my @queries=split(/\&/,$what); |
|
my $qresult=''; |
|
my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER()); |
|
if ($hashref) { |
|
for (my $i=0;$i<=$#queries;$i++) { |
|
$qresult.="$hashref->{$queries[$i]}&"; |
|
} |
|
if (&untie_domain_hash($hashref)) { |
|
$qresult=~s/\&$//; |
|
&Reply($client, "$qresult\n", $userinput); |
|
} else { |
|
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
|
"while attempting getdom\n",$userinput); |
|
} |
|
} else { |
|
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". |
|
"while attempting getdom\n",$userinput); |
|
} |
|
|
|
return 1; |
|
} |
|
®ister_handler("getdom", \&get_id_handler, 0, 1, 0); |
|
|
|
|
|
# |
# Puts an id to a domains id database. |
# Puts an id to a domains id database. |
# |
# |
# Parameters: |
# Parameters: |
Line 3879 sub tmp_put_handler {
|
Line 3974 sub tmp_put_handler {
|
|
|
my $userinput = "$cmd:$what"; # Reconstruct for logging. |
my $userinput = "$cmd:$what"; # Reconstruct for logging. |
|
|
|
my ($record,$context) = split(/:/,$what); |
my $store; |
if ($context ne '') { |
|
chomp($context); |
|
$context = &unescape($context); |
|
} |
|
my ($id,$store); |
$tmpsnum++; |
$tmpsnum++; |
my $id=$$.'_'.$clientip.'_'.$tmpsnum; |
if ($context eq 'resetpw') { |
|
$id = &md5_hex(&md5_hex(time.{}.rand().$$)); |
|
} else { |
|
$id = $$.'_'.$clientip.'_'.$tmpsnum; |
|
} |
$id=~s/\W/\_/g; |
$id=~s/\W/\_/g; |
$what=~s/\n//g; |
$record=~s/\n//g; |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { |
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { |
print $store $what; |
print $store $record; |
close $store; |
close $store; |
&Reply($client, "$id\n", $userinput); |
&Reply($client, "$id\n", $userinput); |
} else { |
} else { |
Line 5364 sub make_new_child {
|
Line 5467 sub make_new_child {
|
# my $tmpsnum=0; # Now global |
# my $tmpsnum=0; # Now global |
#---------------------------------------------------- kerberos 5 initialization |
#---------------------------------------------------- kerberos 5 initialization |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) { |
unless (($dist eq 'fedora5') || ($dist eq 'fedora4') |
|
|| ($dist eq 'suse9.3')) { |
&Authen::Krb5::init_ets(); |
&Authen::Krb5::init_ets(); |
} |
} |
|
|
Line 5790 sub validate_user {
|
Line 5894 sub validate_user {
|
# Authenticate via installation specific authentcation method: |
# Authenticate via installation specific authentcation method: |
$validated = &localauth::localauth($user, |
$validated = &localauth::localauth($user, |
$password, |
$password, |
$contentpwd); |
$contentpwd, |
|
$domain); |
} else { # Unrecognized auth is also bad. |
} else { # Unrecognized auth is also bad. |
$validated = 0; |
$validated = 0; |
} |
} |
Line 5816 sub addline {
|
Line 5921 sub addline {
|
my ($fname,$hostid,$ip,$newline)=@_; |
my ($fname,$hostid,$ip,$newline)=@_; |
my $contents; |
my $contents; |
my $found=0; |
my $found=0; |
my $expr='^'.$hostid.':'.$ip.':'; |
my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':'; |
$expr =~ s/\./\\\./g; |
|
my $sh; |
my $sh; |
if ($sh=IO::File->new("$fname.subscription")) { |
if ($sh=IO::File->new("$fname.subscription")) { |
while (my $subline=<$sh>) { |
while (my $subline=<$sh>) { |