version 1.287, 2005/06/27 10:27:02
|
version 1.301, 2005/10/17 20:09:01
|
Line 48 use localauth;
|
Line 48 use localauth;
|
use localenroll; |
use localenroll; |
use localstudentphoto; |
use localstudentphoto; |
use File::Copy; |
use File::Copy; |
|
use File::Find; |
use LONCAPA::ConfigFileEdit; |
use LONCAPA::ConfigFileEdit; |
use LONCAPA::lonlocal; |
use LONCAPA::lonlocal; |
use LONCAPA::lonssl; |
use LONCAPA::lonssl; |
Line 1363 sub du_handler {
|
Line 1364 sub du_handler {
|
# etc. |
# etc. |
# |
# |
if (-d $ududir) { |
if (-d $ududir) { |
# And as Shakespeare would say to make |
my $total_size=0; |
# assurance double sure, |
my $code=sub { |
# use execute_command to ensure that the command is not executed in |
if ($_=~/\.\d+\./) { return;} |
# a shell that can screw us up. |
if ($_=~/\.meta$/) { return;} |
|
$total_size+=(stat($_))[7]; |
my $duout = execute_command("du -ks $ududir"); |
}; |
$duout=~s/[^\d]//g; #preserve only the numbers |
chdir($ududir); |
&Reply($client,"$duout\n","$cmd:$ududir"); |
find($code,$ududir); |
|
$total_size=int($total_size/1024); |
|
&Reply($client,"$total_size\n","$cmd:$ududir"); |
} else { |
} else { |
|
|
&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); |
&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); |
|
|
} |
} |
return 1; |
return 1; |
} |
} |
Line 1413 sub ls_handler {
|
Line 1414 sub ls_handler {
|
if(-d $ulsdir) { |
if(-d $ulsdir) { |
if (opendir(LSDIR,$ulsdir)) { |
if (opendir(LSDIR,$ulsdir)) { |
while ($ulsfn=readdir(LSDIR)) { |
while ($ulsfn=readdir(LSDIR)) { |
undef $obs, $rights; |
undef($obs); |
|
undef($rights); |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
#We do some obsolete checking here |
#We do some obsolete checking here |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
my @obsolete=<FILE>; |
my @obsolete=<FILE>; |
foreach my $obsolete (@obsolete) { |
foreach my $obsolete (@obsolete) { |
if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } |
if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } |
if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } |
if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } |
} |
} |
} |
} |
Line 1480 sub ls2_handler {
|
Line 1482 sub ls2_handler {
|
if(-d $ulsdir) { |
if(-d $ulsdir) { |
if (opendir(LSDIR,$ulsdir)) { |
if (opendir(LSDIR,$ulsdir)) { |
while ($ulsfn=readdir(LSDIR)) { |
while ($ulsfn=readdir(LSDIR)) { |
undef $obs, $rights; |
undef($obs); |
|
undef($rights); |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
#We do some obsolete checking here |
#We do some obsolete checking here |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
my @obsolete=<FILE>; |
my @obsolete=<FILE>; |
foreach my $obsolete (@obsolete) { |
foreach my $obsolete (@obsolete) { |
if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } |
if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } |
if($obsolete =~ m|(<copyright>)(default)|) { |
if($obsolete =~ m|(<copyright>)(default)|) { |
$rights = 1; |
$rights = 1; |
} |
} |
Line 1835 sub change_authentication_handler {
|
Line 1838 sub change_authentication_handler {
|
&logthis("Result of password change for $uname: ".$result); |
&logthis("Result of password change for $uname: ".$result); |
if ($result eq "ok") { |
if ($result eq "ok") { |
&Reply($client, "$result\n") |
&Reply($client, "$result\n") |
} |
} else { |
else { |
|
&Failure($client, "$result\n"); |
&Failure($client, "$result\n"); |
} |
} |
} |
} else { |
else { |
|
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); |
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); |
# |
# |
# If the current auth mode is internal, and the old auth mode was |
# If the current auth mode is internal, and the old auth mode was |
Line 1972 sub update_resource_handler {
|
Line 1973 sub update_resource_handler {
|
alarm(0); |
alarm(0); |
} |
} |
rename($transname,$fname); |
rename($transname,$fname); |
|
use Cache::Memcached; |
|
my $memcache= |
|
new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
|
my $url=$fname; |
|
$url=~s-^/home/httpd/html--; |
|
my $id=&escape('meta:'.$url); |
|
$memcache->delete($id); |
} |
} |
} |
} |
&Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
Line 3501 sub get_id_handler {
|
Line 3509 sub get_id_handler {
|
®ister_handler("idget", \&get_id_handler, 0, 1, 0); |
®ister_handler("idget", \&get_id_handler, 0, 1, 0); |
|
|
# |
# |
|
# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database |
|
# |
|
# Parameters |
|
# $cmd - Command keyword that caused us to be dispatched. |
|
# $tail - Tail of the command. Consists of a colon separated: |
|
# domain - the domain whose dcmail we are recording |
|
# email Consists of key=value pair |
|
# where key is unique msgid |
|
# and value is message (in XML) |
|
# $client - Socket open on the client. |
|
# |
|
# Returns: |
|
# 1 - indicating processing should continue. |
|
# Side effects |
|
# reply is written to $client. |
|
# |
|
sub put_dcmail_handler { |
|
my ($cmd,$tail,$client) = @_; |
|
my $userinput = "$cmd:$tail"; |
|
|
|
my ($udom,$what)=split(/:/,$tail); |
|
chomp($what); |
|
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); |
|
if ($hashref) { |
|
my ($key,$value)=split(/=/,$what); |
|
$hashref->{$key}=$value; |
|
} |
|
if (untie(%$hashref)) { |
|
&Reply($client, "ok\n", $userinput); |
|
} else { |
|
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
|
"while attempting dcmailput\n", $userinput); |
|
} |
|
return 1; |
|
} |
|
®ister_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0); |
|
|
|
# |
|
# Retrieves broadcast e-mail from nohist_dcmail database |
|
# Returns to client an & separated list of key=value pairs, |
|
# where key is msgid and value is message information. |
|
# |
|
# Parameters |
|
# $cmd - Command keyword that caused us to be dispatched. |
|
# $tail - Tail of the command. Consists of a colon separated: |
|
# domain - the domain whose dcmail table we dump |
|
# startfilter - beginning of time window |
|
# endfilter - end of time window |
|
# sendersfilter - & separated list of username:domain |
|
# for senders to search for. |
|
# $client - Socket open on the client. |
|
# |
|
# Returns: |
|
# 1 - indicating processing should continue. |
|
# Side effects |
|
# reply (& separated list of msgid=messageinfo pairs) is |
|
# written to $client. |
|
# |
|
sub dump_dcmail_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
|
|
my $userinput = "$cmd:$tail"; |
|
my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail); |
|
chomp($sendersfilter); |
|
my @senders = (); |
|
if (defined($startfilter)) { |
|
$startfilter=&unescape($startfilter); |
|
} else { |
|
$startfilter='.'; |
|
} |
|
if (defined($endfilter)) { |
|
$endfilter=&unescape($endfilter); |
|
} else { |
|
$endfilter='.'; |
|
} |
|
if (defined($sendersfilter)) { |
|
$sendersfilter=&unescape($sendersfilter); |
|
@senders = map { &unescape($_) } split(/\&/,$sendersfilter); |
|
} |
|
|
|
my $qresult=''; |
|
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); |
|
if ($hashref) { |
|
while (my ($key,$value) = each(%$hashref)) { |
|
my $match = 1; |
|
my ($timestamp,$subj,$uname,$udom) = split(/:/,&unescape($key),5); |
|
$timestamp = &unescape($timestamp); |
|
$subj = &unescape($subj); |
|
$uname = &unescape($uname); |
|
$udom = &unescape($udom); |
|
unless ($startfilter eq '.' || !defined($startfilter)) { |
|
if ($timestamp < $startfilter) { |
|
$match = 0; |
|
} |
|
} |
|
unless ($endfilter eq '.' || !defined($endfilter)) { |
|
if ($timestamp > $endfilter) { |
|
$match = 0; |
|
} |
|
} |
|
unless (@senders < 1) { |
|
unless (grep/^$uname:$udom$/,@senders) { |
|
$match = 0; |
|
} |
|
} |
|
if ($match == 1) { |
|
$qresult.=$key.'='.$value.'&'; |
|
} |
|
} |
|
if (untie(%$hashref)) { |
|
chop($qresult); |
|
&Reply($client, "$qresult\n", $userinput); |
|
} else { |
|
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
|
"while attempting dcmaildump\n", $userinput); |
|
} |
|
} else { |
|
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". |
|
"while attempting dcmaildump\n", $userinput); |
|
} |
|
return 1; |
|
} |
|
|
|
®ister_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0); |
|
|
|
# |
|
# Puts domain roles in nohist_domainroles database |
|
# |
|
# Parameters |
|
# $cmd - Command keyword that caused us to be dispatched. |
|
# $tail - Tail of the command. Consists of a colon separated: |
|
# domain - the domain whose roles we are recording |
|
# role - Consists of key=value pair |
|
# where key is unique role |
|
# and value is start/end date information |
|
# $client - Socket open on the client. |
|
# |
|
# Returns: |
|
# 1 - indicating processing should continue. |
|
# Side effects |
|
# reply is written to $client. |
|
# |
|
|
|
sub put_domainroles_handler { |
|
my ($cmd,$tail,$client) = @_; |
|
|
|
my $userinput = "$cmd:$tail"; |
|
my ($udom,$what)=split(/:/,$tail); |
|
chomp($what); |
|
my @pairs=split(/\&/,$what); |
|
my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); |
|
if ($hashref) { |
|
foreach my $pair (@pairs) { |
|
my ($key,$value)=split(/=/,$pair); |
|
$hashref->{$key}=$value; |
|
} |
|
if (untie(%$hashref)) { |
|
&Reply($client, "ok\n", $userinput); |
|
} else { |
|
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
|
"while attempting domroleput\n", $userinput); |
|
} |
|
} else { |
|
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
|
"while attempting domroleput\n", $userinput); |
|
} |
|
|
|
return 1; |
|
} |
|
|
|
®ister_handler("domroleput", \&put_domainroles_handler, 0, 1, 0); |
|
|
|
# |
|
# Retrieves domain roles from nohist_domainroles database |
|
# Returns to client an & separated list of key=value pairs, |
|
# where key is role and value is start and end date information. |
|
# |
|
# Parameters |
|
# $cmd - Command keyword that caused us to be dispatched. |
|
# $tail - Tail of the command. Consists of a colon separated: |
|
# domain - the domain whose domain roles table we dump |
|
# $client - Socket open on the client. |
|
# |
|
# Returns: |
|
# 1 - indicating processing should continue. |
|
# Side effects |
|
# reply (& separated list of role=start/end info pairs) is |
|
# written to $client. |
|
# |
|
sub dump_domainroles_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
|
|
my $userinput = "$cmd:$tail"; |
|
my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail); |
|
chomp($rolesfilter); |
|
my @roles = (); |
|
if (defined($startfilter)) { |
|
$startfilter=&unescape($startfilter); |
|
} else { |
|
$startfilter='.'; |
|
} |
|
if (defined($endfilter)) { |
|
$endfilter=&unescape($endfilter); |
|
} else { |
|
$endfilter='.'; |
|
} |
|
if (defined($rolesfilter)) { |
|
$rolesfilter=&unescape($rolesfilter); |
|
@roles = split(/\&/,$rolesfilter); |
|
} |
|
|
|
my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); |
|
if ($hashref) { |
|
my $qresult = ''; |
|
while (my ($key,$value) = each(%$hashref)) { |
|
my $match = 1; |
|
my ($start,$end) = split(/:/,&unescape($value)); |
|
my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key)); |
|
unless ($startfilter eq '.' || !defined($startfilter)) { |
|
if ($start >= $startfilter) { |
|
$match = 0; |
|
} |
|
} |
|
unless ($endfilter eq '.' || !defined($endfilter)) { |
|
if ($end <= $endfilter) { |
|
$match = 0; |
|
} |
|
} |
|
unless (@roles < 1) { |
|
unless (grep/^$trole$/,@roles) { |
|
$match = 0; |
|
} |
|
} |
|
if ($match == 1) { |
|
$qresult.=$key.'='.$value.'&'; |
|
} |
|
} |
|
if (untie(%$hashref)) { |
|
chop($qresult); |
|
&Reply($client, "$qresult\n", $userinput); |
|
} else { |
|
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
|
"while attempting domrolesdump\n", $userinput); |
|
} |
|
} else { |
|
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". |
|
"while attempting domrolesdump\n", $userinput); |
|
} |
|
return 1; |
|
} |
|
|
|
®ister_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0); |
|
|
|
|
# Process the tmpput command I'm not sure what this does.. Seems to |
# Process the tmpput command I'm not sure what this does.. Seems to |
# create a file in the lonDaemons/tmp directory of the form $id.tmp |
# create a file in the lonDaemons/tmp directory of the form $id.tmp |
# where Id is the client's ip concatenated with a sequence number. |
# where Id is the client's ip concatenated with a sequence number. |
Line 4404 sub ReadHostTable {
|
Line 4666 sub ReadHostTable {
|
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
my $myloncapaname = $perlvar{'lonHostID'}; |
my $myloncapaname = $perlvar{'lonHostID'}; |
Debug("My loncapa name is : $myloncapaname"); |
Debug("My loncapa name is : $myloncapaname"); |
|
my %name_to_ip; |
while (my $configline=<CONFIG>) { |
while (my $configline=<CONFIG>) { |
if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) { |
if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) { |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
$name=~s/\s//g; |
$name=~s/\s//g; |
my $ip = gethostbyname($name); |
my $ip; |
if (length($ip) ne 4) { |
if (!exists($name_to_ip{$name})) { |
&logthis("Skipping host $id name $name no IP $ip found\n"); |
$ip = gethostbyname($name); |
next; |
if (!$ip || length($ip) ne 4) { |
|
&logthis("Skipping host $id name $name no IP found\n"); |
|
next; |
|
} |
|
$ip=inet_ntoa($ip); |
|
$name_to_ip{$name} = $ip; |
|
} else { |
|
$ip = $name_to_ip{$name}; |
} |
} |
$ip=inet_ntoa($ip); |
|
$hostid{$ip}=$id; # LonCAPA name of host by IP. |
$hostid{$ip}=$id; # LonCAPA name of host by IP. |
$hostdom{$id}=$domain; # LonCAPA domain name of host. |
$hostdom{$id}=$domain; # LonCAPA domain name of host. |
$hostip{$id}=$ip; # IP address of host. |
$hostip{$id}=$ip; # IP address of host. |
Line 4857 sub make_new_child {
|
Line 5126 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(); |
if ($dist ne 'fedora4') { |
unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) { |
&Authen::Krb5::init_ets(); |
&Authen::Krb5::init_ets(); |
} |
} |
|
|
Line 5069 sub is_author {
|
Line 5338 sub is_author {
|
# user - Name of the user for which the role is being put. |
# user - Name of the user for which the role is being put. |
# authtype - The authentication type associated with the user. |
# authtype - The authentication type associated with the user. |
# |
# |
sub manage_permissions |
sub manage_permissions { |
{ |
|
|
|
|
|
my ($request, $domain, $user, $authtype) = @_; |
my ($request, $domain, $user, $authtype) = @_; |
|
|
&Debug("manage_permissions: $request $domain $user $authtype"); |
&Debug("manage_permissions: $request $domain $user $authtype"); |
|
|
# See if the request is of the form /$domain/_au |
# See if the request is of the form /$domain/_au |
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... |
if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput... |
my $execdir = $perlvar{'lonDaemons'}; |
my $execdir = $perlvar{'lonDaemons'}; |
my $userhome= "/home/$user" ; |
my $userhome= "/home/$user" ; |
&logthis("system $execdir/lchtmldir $userhome $user $authtype"); |
&logthis("system $execdir/lchtmldir $userhome $user $authtype"); |
Line 5471 sub thisversion {
|
Line 5737 sub thisversion {
|
sub subscribe { |
sub subscribe { |
my ($userinput,$clientip)=@_; |
my ($userinput,$clientip)=@_; |
my $result; |
my $result; |
my ($cmd,$fname)=split(/:/,$userinput); |
my ($cmd,$fname)=split(/:/,$userinput,2); |
my $ownership=&ishome($fname); |
my $ownership=&ishome($fname); |
if ($ownership eq 'owner') { |
if ($ownership eq 'owner') { |
# explitly asking for the current version? |
# explitly asking for the current version? |