version 1.866, 2007/04/05 22:04:49
|
version 1.871, 2007/04/20 21:48:09
|
Line 31 package Apache::lonnet;
|
Line 31 package Apache::lonnet;
|
|
|
use strict; |
use strict; |
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Headers; |
|
use HTTP::Date; |
use HTTP::Date; |
# use Date::Parse; |
# use Date::Parse; |
use vars |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
qw(%perlvar %badServerCache %spareid |
$_64bit %env); |
%pr %prp $memcache %packagetab |
|
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
$tmpdir $_64bit %env); |
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, |
|
%courseownerbuf, %coursetypebuf); |
|
|
use IO::Socket; |
use IO::Socket; |
use GDBM_File; |
use GDBM_File; |
use HTML::LCParser; |
use HTML::LCParser; |
use HTML::Parser; |
|
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
use Storable qw(thaw nfreeze); |
use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( gettimeofday tv_interval ); |
use Cache::Memcached; |
use Cache::Memcached; |
use Digest::MD5; |
use Digest::MD5; |
Line 182 sub subreply {
|
Line 181 sub subreply {
|
$client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
$client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
Timeout => 10); |
Timeout => 10); |
if($client) { |
if ($client) { |
last; # Connected! |
last; # Connected! |
} else { |
} else { |
&create_connection(&hostname($server),$server); |
&create_connection(&hostname($server),$server); |
Line 830 sub retrieve_inst_usertypes {
|
Line 829 sub retrieve_inst_usertypes {
|
return (\%returnhash,\@order); |
return (\%returnhash,\@order); |
} |
} |
|
|
|
sub is_domainimage { |
|
my ($url) = @_; |
|
if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { |
|
if (&domain($1) ne '') { |
|
return '1'; |
|
} |
|
} |
|
return; |
|
} |
|
|
# --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
|
|
sub assign_access_key { |
sub assign_access_key { |
Line 2137 sub get_my_roles {
|
Line 2146 sub get_my_roles {
|
my %returnhash=(); |
my %returnhash=(); |
my $now=time; |
my $now=time; |
foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
my ($role,$tend,$tstart); |
|
if ($context eq 'userroles') { |
|
($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); |
|
} else { |
|
($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
|
} |
if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
my $status = 'active'; |
my $status = 'active'; |
if (($tend) && ($tend<$now)) { |
if (($tend) && ($tend<$now)) { |
Line 2155 sub get_my_roles {
|
Line 2169 sub get_my_roles {
|
next; |
next; |
} |
} |
} |
} |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
my ($rolecode,$username,$domain,$section,$area); |
|
if ($context eq 'userroles') { |
|
($area,$rolecode) = split(/_/,$entry); |
|
(undef,$domain,$username,$section) = split(/\//,$area); |
|
} else { |
|
($role,$username,$domain,$section) = split(/\:/,$entry); |
|
} |
if (ref($roledoms) eq 'ARRAY') { |
if (ref($roledoms) eq 'ARRAY') { |
if (!grep(/^\Q$domain\E$/,@{$roledoms})) { |
if (!grep(/^\Q$domain\E$/,@{$roledoms})) { |
next; |
next; |
Line 2165 sub get_my_roles {
|
Line 2185 sub get_my_roles {
|
if (!grep(/^\Q$role\E$/,@{$roles})) { |
if (!grep(/^\Q$role\E$/,@{$roles})) { |
next; |
next; |
} |
} |
} |
} |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
} |
} |
return %returnhash; |
return %returnhash; |
Line 5274 sub save_selected_files {
|
Line 5294 sub save_selected_files {
|
my ($user, $path, @files) = @_; |
my ($user, $path, @files) = @_; |
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my @other_files = &files_not_in_path($user, $path); |
my @other_files = &files_not_in_path($user, $path); |
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open (OUT, '>'.$tmpdir.$filename); |
foreach my $file (@files) { |
foreach my $file (@files) { |
print (OUT $env{'form.currentpath'}.$file."\n"); |
print (OUT $env{'form.currentpath'}.$file."\n"); |
} |
} |
Line 7642 sub correct_line_ends {
|
Line 7662 sub correct_line_ends {
|
sub goodbye { |
sub goodbye { |
&logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
#not converted to using infrastruture and probably shouldn't be |
#not converted to using infrastruture and probably shouldn't be |
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache)))); |
#converted |
#converted |
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
&logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); |
&logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache)))); |
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); |
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache)))); |
#1.1 only |
#1.1 only |
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); |
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache)))); |
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); |
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache)))); |
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); |
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache)))); |
&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
&logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered)))); |
&logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
&logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
&logthis(sprintf("%-20s is %s",'hits',$hits)); |
&logthis(sprintf("%-20s is %s",'hits',$hits)); |
&flushcourselogs(); |
&flushcourselogs(); |
Line 7661 sub goodbye {
|
Line 7681 sub goodbye {
|
} |
} |
|
|
sub get_dns { |
sub get_dns { |
my ($url,$func) = @_; |
my ($url,$func,$ignore_cache) = @_; |
|
if (!$ignore_cache) { |
|
my ($content,$cached)= |
|
&Apache::lonnet::is_cached_new('dns',$url); |
|
if ($cached) { |
|
&$func($content); |
|
return; |
|
} |
|
} |
|
|
|
my %alldns; |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
$dns = $1; |
$alldns{$1} = 1; |
|
} |
|
while (%alldns) { |
|
my ($dns) = keys(%alldns); |
|
delete($alldns{$dns}); |
my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
my $request=new HTTP::Request('GET',"http://$dns$url"); |
my $request=new HTTP::Request('GET',"http://$dns$url"); |
my $response=$ua->request($request); |
my $response=$ua->request($request); |
next if ($response->is_error()); |
next if ($response->is_error()); |
my @content = split("\n",$response->content); |
my @content = split("\n",$response->content); |
|
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); |
&$func(\@content); |
&$func(\@content); |
|
return; |
} |
} |
close($config); |
close($config); |
|
my $which = (split('/',$url))[3]; |
|
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
|
open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); |
|
my @content = <$config>; |
|
&$func(\@content); |
|
return; |
} |
} |
# ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
{ |
{ |
Line 7703 sub get_dns {
|
Line 7745 sub get_dns {
|
} |
} |
|
|
sub load_domain_tab { |
sub load_domain_tab { |
&get_dns('/adm/dns/domain',\&parse_domain_tab); |
my ($ignore_cache) = @_; |
|
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); |
my $fh; |
my $fh; |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
my @lines = <$fh>; |
my @lines = <$fh>; |
Line 7760 sub get_dns {
|
Line 7803 sub get_dns {
|
} |
} |
|
|
sub load_hosts_tab { |
sub load_hosts_tab { |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab); |
my ($ignore_cache) = @_; |
|
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
my @config = <$config>; |
my @config = <$config>; |
&parse_hosts_tab(\@config); |
&parse_hosts_tab(\@config); |
Line 7836 sub get_dns {
|
Line 7880 sub get_dns {
|
my %iphost; |
my %iphost; |
my %name_to_ip; |
my %name_to_ip; |
my %lonid_to_ip; |
my %lonid_to_ip; |
|
|
|
my %valid_ip; |
|
sub valid_ip { |
|
my ($ip) = @_; |
|
if (exists($iphost{$ip}) || exists($valid_ip{$ip})) { |
|
return 1; |
|
} |
|
my $name = gethostbyip($ip); |
|
my $lonid = &hostname($name); |
|
if (defined($lonid)) { |
|
$valid_ip{$ip} = $lonid; |
|
return 1; |
|
} |
|
my %iphosts = &get_iphost(); |
|
if (ref($iphost{$ip})) { |
|
return 1; |
|
} |
|
} |
|
|
sub get_hosts_from_ip { |
sub get_hosts_from_ip { |
my ($ip) = @_; |
my ($ip) = @_; |
my %iphosts = &get_iphost(); |
my %iphosts = &get_iphost(); |
Line 7866 sub get_dns {
|
Line 7929 sub get_dns {
|
} |
} |
|
|
sub get_iphost { |
sub get_iphost { |
if (%iphost) { return %iphost; } |
my ($ignore_cache) = @_; |
|
if (!$ignore_cache) { |
|
if (%iphost) { |
|
return %iphost; |
|
} |
|
my ($ip_info,$cached)= |
|
&Apache::lonnet::is_cached_new('iphost','iphost'); |
|
if ($cached) { |
|
%iphost = %{$ip_info->[0]}; |
|
%name_to_ip = %{$ip_info->[1]}; |
|
%lonid_to_ip = %{$ip_info->[2]}; |
|
return %iphost; |
|
} |
|
} |
my %hostname = &all_hostnames(); |
my %hostname = &all_hostnames(); |
foreach my $id (keys(%hostname)) { |
foreach my $id (keys(%hostname)) { |
my $name=&hostname($id); |
my $name=&hostname($id); |
Line 7885 sub get_dns {
|
Line 7961 sub get_dns {
|
$lonid_to_ip{$id} = $ip; |
$lonid_to_ip{$id} = $ip; |
push(@{$iphost{$ip}},$id); |
push(@{$iphost{$ip}},$id); |
} |
} |
|
&Apache::lonnet::do_cache_new('iphost','iphost', |
|
[\%iphost,\%name_to_ip,\%lonid_to_ip], |
|
24*60*60); |
|
|
return %iphost; |
return %iphost; |
} |
} |
} |
} |