|
version 1.846, 2007/03/08 01:58:41
|
version 1.859, 2007/04/03 18:16:57
|
|
Line 35 use HTTP::Headers;
|
Line 35 use HTTP::Headers;
|
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
# use Date::Parse; |
| use vars |
use vars |
| qw(%perlvar %badServerCache %iphost %spareid |
qw(%perlvar %badServerCache %spareid |
| %pr %prp $memcache %packagetab |
%pr %prp $memcache %packagetab |
| %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf |
|
Line 144 sub logperm {
|
Line 144 sub logperm {
|
| return 1; |
return 1; |
| } |
} |
| |
|
| |
sub create_connection { |
| |
my ($hostname,$lonid) = @_; |
| |
my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
| |
Type => SOCK_STREAM, |
| |
Timeout => 10); |
| |
return 0 if (!$client); |
| |
print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); |
| |
my $result = <$client>; |
| |
chomp($result); |
| |
return 1 if ($result eq 'done'); |
| |
return 0; |
| |
} |
| |
|
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
|
Line 170 sub subreply {
|
Line 184 sub subreply {
|
| Timeout => 10); |
Timeout => 10); |
| if($client) { |
if($client) { |
| last; # Connected! |
last; # Connected! |
| |
} else { |
| |
&create_connection(&hostname($server),$server); |
| } |
} |
| sleep(1); # Try again later if failed connection. |
sleep(1); # Try again later if failed connection. |
| } |
} |
| my $answer; |
my $answer; |
| if ($client) { |
if ($client) { |
|
Line 1010 my %remembered;
|
Line 1026 my %remembered;
|
| my %accessed; |
my %accessed; |
| my $kicks=0; |
my $kicks=0; |
| my $hits=0; |
my $hits=0; |
| |
sub make_key { |
| |
my ($name,$id) = @_; |
| |
if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); } |
| |
return &escape($name.':'.$id); |
| |
} |
| |
|
| sub devalidate_cache_new { |
sub devalidate_cache_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| $memcache->delete($id); |
$memcache->delete($id); |
| delete($remembered{$id}); |
delete($remembered{$id}); |
| delete($accessed{$id}); |
delete($accessed{$id}); |
|
Line 1021 sub devalidate_cache_new {
|
Line 1043 sub devalidate_cache_new {
|
| |
|
| sub is_cached_new { |
sub is_cached_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| if (exists($remembered{$id})) { |
if (exists($remembered{$id})) { |
| if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$id}=[&gettimeofday()]; |
|
Line 1044 sub is_cached_new {
|
Line 1066 sub is_cached_new {
|
| |
|
| sub do_cache_new { |
sub do_cache_new { |
| my ($name,$id,$value,$time,$debug) = @_; |
my ($name,$id,$value,$time,$debug) = @_; |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| my $setvalue=$value; |
my $setvalue=$value; |
| if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
| $setvalue='__undef__'; |
$setvalue='__undef__'; |
|
Line 1494 sub clean_filename {
|
Line 1516 sub clean_filename {
|
| # $coursedoc - if true up to the current course |
# $coursedoc - if true up to the current course |
| # if false |
# if false |
| # $subdir - directory in userfile to store the file into |
# $subdir - directory in userfile to store the file into |
| # $parser, $allfiles, $codebase - unknown |
# $parser - instruction to parse file for objects ($parser = parse) |
| # |
# $allfiles - reference to hash for embedded objects |
| |
# $codebase - reference to hash for codebase of java objects |
| |
# $desuname - username for permanent storage of uploaded file |
| |
# $dsetudom - domain for permanaent storage of uploaded file |
| |
# |
| # output: url of file in userspace, or error: <message> |
# output: url of file in userspace, or error: <message> |
| # or /adm/notfound.html if failure to upload occurse |
# or /adm/notfound.html if failure to upload occurse |
| |
|
|
Line 1613 sub finishuserfileupload {
|
Line 1639 sub finishuserfileupload {
|
| ' for embedded media: '.$parse_result); |
' for embedded media: '.$parse_result); |
| } |
} |
| } |
} |
| |
|
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| my $docuhome=&homeserver($docuname,$docudom); |
my $docuhome=&homeserver($docuname,$docudom); |
|
Line 1625 sub finishuserfileupload {
|
Line 1652 sub finishuserfileupload {
|
| &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
| ': '.$fetchresult); |
': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
| |
|
| sub extract_embedded_items { |
sub extract_embedded_items { |
|
Line 2047 sub get_course_adv_roles {
|
Line 2074 sub get_course_adv_roles {
|
| } |
} |
| |
|
| sub get_my_roles { |
sub get_my_roles { |
| my ($uname,$udom,$types,$roles,$roledoms)=@_; |
my ($uname,$udom,$context,$types,$roles,$roledoms)=@_; |
| unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($uname)) { $uname=$env{'user.name'}; } |
| unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
| my %dumphash= |
my %dumphash; |
| |
if ($context eq 'userroles') { |
| |
%dumphash = &dump('roles',$udom,$uname); |
| |
} else { |
| |
%dumphash= |
| &dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
| |
} |
| my %returnhash=(); |
my %returnhash=(); |
| my $now=time; |
my $now=time; |
| foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
|
Line 4327 sub courselog_query {
|
Line 4359 sub courselog_query {
|
| } |
} |
| |
|
| sub userlog_query { |
sub userlog_query { |
| |
# |
| |
# possible filters: |
| |
# action: log check role |
| |
# start: timestamp |
| |
# end: timestamp |
| |
# |
| my ($uname,$udom,%filters)=@_; |
my ($uname,$udom,%filters)=@_; |
| return &log_query($uname,$udom,'userlog',%filters); |
return &log_query($uname,$udom,'userlog',%filters); |
| } |
} |
|
Line 6176 sub packages_tab_default {
|
Line 6214 sub packages_tab_default {
|
| $do_default=1; |
$do_default=1; |
| } elsif ($pack_type eq 'extension') { |
} elsif ($pack_type eq 'extension') { |
| push(@extension,[$package,$pack_type,$pack_part]); |
push(@extension,[$package,$pack_type,$pack_part]); |
| } else { |
} elsif ($pack_part eq $part) { |
| |
# only look at packages defaults for packages that this id is |
| push(@specifics,[$package,$pack_type,$pack_part]); |
push(@specifics,[$package,$pack_type,$pack_part]); |
| } |
} |
| } |
} |
|
Line 6894 sub getCODE {
|
Line 6933 sub getCODE {
|
| |
|
| sub rndseed { |
sub rndseed { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| |
|
| my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
| if (!$symb) { |
if (!$symb) { |
| unless ($symb=$wsymb) { return time; } |
unless ($symb=$wsymb) { return time; } |
|
Line 7403 sub hreflocation {
|
Line 7441 sub hreflocation {
|
| } |
} |
| |
|
| sub current_machine_domains { |
sub current_machine_domains { |
| my $hostname=&hostname($perlvar{'lonHostID'}); |
return &machine_domains(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_domains { |
| |
my ($hostname) = @_; |
| my @domains; |
my @domains; |
| my %hostname = &all_hostnames(); |
my %hostname = &all_hostnames(); |
| while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
|
Line 7416 sub current_machine_domains {
|
Line 7458 sub current_machine_domains {
|
| } |
} |
| |
|
| sub current_machine_ids { |
sub current_machine_ids { |
| my $hostname=&hostname($perlvar{'lonHostID'}); |
return &machine_ids(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_ids { |
| |
my ($hostname) = @_; |
| |
$hostname ||= &hostname($perlvar{'lonHostID'}); |
| my @ids; |
my @ids; |
| my %hostname = &all_hostnames(); |
my %hostname = &all_hostnames(); |
| while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
|
Line 7557 sub goodbye {
|
Line 7604 sub goodbye {
|
| } |
} |
| |
|
| BEGIN { |
BEGIN { |
| |
|
| # ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
| unless ($readit) { |
unless ($readit) { |
| { |
{ |
|
Line 7564 BEGIN {
|
Line 7612 BEGIN {
|
| %perlvar = (%perlvar,%{$configvars}); |
%perlvar = (%perlvar,%{$configvars}); |
| } |
} |
| |
|
| |
sub get_dns { |
| |
my ($url,$func) = @_; |
| |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| |
foreach my $dns (<$config>) { |
| |
next if ($dns !~ /^\^(\S*)/x); |
| |
$dns = $1; |
| |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',"http://$dns$url"); |
| |
my $response=$ua->request($request); |
| |
next if ($response->is_error()); |
| |
my @content = split("\n",$response->content); |
| |
&$func(\@content); |
| |
} |
| |
close($config); |
| |
} |
| # ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
| { |
{ |
| |
my $loaded; |
| my %domain; |
my %domain; |
| |
|
| my $fh; |
sub parse_domain_tab { |
| if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { |
my ($lines) = @_; |
| while (my $line = <$fh>) { |
foreach my $line (@$lines) { |
| next if ($line =~ /^(\#|\s*$ )/); |
next if ($line =~ /^(\#|\s*$ )/x); |
| |
|
| chomp($line); |
chomp($line); |
| my ($name,@elements) = split(/:/,$line,9); |
my ($name,@elements) = split(/:/,$line,9); |
| my %this_domain; |
my %this_domain; |
| foreach my $field ('description', 'auth_def', 'auth_arg_def', |
foreach my $field ('description', 'auth_def', 'auth_arg_def', |
| 'lang_def', 'city', 'longi', 'lati', |
'lang_def', 'city', 'longi', 'lati', |
|
Line 7582 BEGIN {
|
Line 7646 BEGIN {
|
| $this_domain{$field} = shift(@elements); |
$this_domain{$field} = shift(@elements); |
| } |
} |
| $domain{$name} = \%this_domain; |
$domain{$name} = \%this_domain; |
| # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
&logthis("Domain.tab: $name ".$domain{$name}{'description'} ); |
| |
} |
| |
} |
| |
|
| |
sub load_domain_tab { |
| |
&get_dns('/adm/dns/domain',\&parse_domain_tab); |
| |
my $fh; |
| |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
| |
my @lines = <$fh>; |
| |
&parse_domain_tab(\@lines); |
| } |
} |
| |
close($fh); |
| |
$loaded = 1; |
| } |
} |
| close ($fh); |
|
| |
|
| sub domain { |
sub domain { |
| |
&load_domain_tab() if (!$loaded); |
| |
|
| my ($name,$what) = @_; |
my ($name,$what) = @_; |
| return if ( !exists($domain{$name}) ); |
return if ( !exists($domain{$name}) ); |
| |
|
|
Line 7604 BEGIN {
|
Line 7680 BEGIN {
|
| my %hostname; |
my %hostname; |
| my %hostdom; |
my %hostdom; |
| my %libserv; |
my %libserv; |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
my $loaded; |
| |
|
| while (my $configline=<$config>) { |
sub parse_hosts_tab { |
| next if ($configline =~ /^(\#|\s*$)/); |
my ($file) = @_; |
| chomp($configline); |
foreach my $configline (@$file) { |
| my ($id,$domain,$role,$name)=split(/:/,$configline); |
next if ($configline =~ /^(\#|\s*$ )/x); |
| $name=~s/\s//g; |
next if ($configline =~ /^\^/); |
| if ($id && $domain && $role && $name) { |
chomp($configline); |
| $hostname{$id}=$name; |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
| $hostdom{$id}=$domain; |
$name=~s/\s//g; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($id && $domain && $role && $name) { |
| } |
$hostname{$id}=$name; |
| |
$hostdom{$id}=$domain; |
| |
if ($role eq 'library') { $libserv{$id}=$name; } |
| |
} |
| |
&logthis("Hosts.tab: $name ".$id ); |
| |
} |
| } |
} |
| close($config); |
|
| |
sub load_hosts_tab { |
| |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab); |
| |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| |
my @config = <$config>; |
| |
&parse_hosts_tab(\@config); |
| |
close($config); |
| |
$loaded=1; |
| |
} |
| |
|
| # FIXME: dev server don't want this, production servers _do_ want this |
# FIXME: dev server don't want this, production servers _do_ want this |
| #&get_iphost(); |
#&get_iphost(); |
| |
|
| sub hostname { |
sub hostname { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my ($lonid) = @_; |
my ($lonid) = @_; |
| return $hostname{$lonid}; |
return $hostname{$lonid}; |
| } |
} |
| |
|
| sub all_hostnames { |
sub all_hostnames { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| return %hostname; |
return %hostname; |
| } |
} |
| |
|
| sub is_library { |
sub is_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| return exists($libserv{$_[0]}); |
return exists($libserv{$_[0]}); |
| } |
} |
| |
|
| sub all_library { |
sub all_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| return %libserv; |
return %libserv; |
| } |
} |
| |
|
| sub get_servers { |
sub get_servers { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my ($domain,$type) = @_; |
my ($domain,$type) = @_; |
| my %possible_hosts = ($type eq 'library') ? %libserv |
my %possible_hosts = ($type eq 'library') ? %libserv |
| : %hostname; |
: %hostname; |
|
Line 7660 BEGIN {
|
Line 7760 BEGIN {
|
| } |
} |
| |
|
| sub host_domain { |
sub host_domain { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my ($lonid) = @_; |
my ($lonid) = @_; |
| return $hostdom{$lonid}; |
return $hostdom{$lonid}; |
| } |
} |
| |
|
| sub all_domains { |
sub all_domains { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my %seen; |
my %seen; |
| my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
| return @uniq; |
return @uniq; |
| } |
} |
| } |
} |
| |
|
| sub get_hosts_from_ip { |
{ |
| my ($ip) = @_; |
my %iphost; |
| my %iphosts = &get_iphost(); |
my %name_to_ip; |
| if (ref($iphosts{$ip})) { |
my %lonid_to_ip; |
| return @{$iphosts{$ip}}; |
sub get_hosts_from_ip { |
| |
my ($ip) = @_; |
| |
my %iphosts = &get_iphost(); |
| |
if (ref($iphosts{$ip})) { |
| |
return @{$iphosts{$ip}}; |
| |
} |
| |
return; |
| } |
} |
| return; |
|
| } |
|
| |
|
| sub get_iphost { |
sub get_host_ip { |
| if (%iphost) { return %iphost; } |
my ($lonid) = @_; |
| my %name_to_ip; |
if (exists($lonid_to_ip{$lonid})) { |
| my %hostname = &all_hostnames(); |
return $lonid_to_ip{$lonid}; |
| foreach my $id (keys(%hostname)) { |
} |
| my $name=$hostname{$id}; |
my $name=&hostname($lonid); |
| my $ip; |
my $ip = gethostbyname($name); |
| if (!exists($name_to_ip{$name})) { |
return if (!$ip || length($ip) ne 4); |
| $ip = gethostbyname($name); |
$ip=inet_ntoa($ip); |
| if (!$ip || length($ip) ne 4) { |
$name_to_ip{$name} = $ip; |
| &logthis("Skipping host $id name $name no IP found"); |
$lonid_to_ip{$lonid} = $ip; |
| next; |
return $ip; |
| |
} |
| |
|
| |
sub get_iphost { |
| |
if (%iphost) { return %iphost; } |
| |
my %hostname = &all_hostnames(); |
| |
foreach my $id (keys(%hostname)) { |
| |
my $name=$hostname{$id}; |
| |
my $ip; |
| |
if (!exists($name_to_ip{$name})) { |
| |
$ip = gethostbyname($name); |
| |
if (!$ip || length($ip) ne 4) { |
| |
&logthis("Skipping host $id name $name no IP found"); |
| |
next; |
| |
} |
| |
$ip=inet_ntoa($ip); |
| |
$name_to_ip{$name} = $ip; |
| |
} else { |
| |
$ip = $name_to_ip{$name}; |
| } |
} |
| $ip=inet_ntoa($ip); |
$lonid_to_ip{$id} = $ip; |
| $name_to_ip{$name} = $ip; |
push(@{$iphost{$ip}},$id); |
| } else { |
|
| $ip = $name_to_ip{$name}; |
|
| } |
} |
| push(@{$iphost{$ip}},$id); |
return %iphost; |
| } |
} |
| return %iphost; |
|
| } |
} |
| |
|
| # ------------------------------------------------------ Read spare server file |
# ------------------------------------------------------ Read spare server file |
|
Line 8034 X<userenvironment()>
|
Line 8157 X<userenvironment()>
|
| B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
| passed in @what from the requested user's environment, returns a hash |
passed in @what from the requested user's environment, returns a hash |
| |
|
| |
=item * |
| |
X<userlog_query()> |
| |
B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's |
| |
activity.log file. %filters defines filters applied when parsing the |
| |
log file. These can be start or end timestamps, or the type of action |
| |
- log to look for Login or Logout events, check for Checkin or |
| |
Checkout, role for role selection. The response is in the form |
| |
timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are |
| |
escaped strings of the action recorded in the activity.log file. |
| |
|
| =back |
=back |
| |
|
| =head2 User Roles |
=head2 User Roles |
|
Line 8063 explanation of a user role term
|
Line 8196 explanation of a user role term
|
| |
|
| =item * |
=item * |
| |
|
| get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are |
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : |
| optional. Returns a hash of a user's roles, with keys set to |
All arguments are optional. Returns a hash of a roles, either for |
| colon-sparated $uname,$udom,and $role, and value set to |
co-author/assistant author roles for a user's Construction Space |
| colon-separated start and end times for the role. If no username and |
(default), or if $context is 'user', roles for the user himself, |
| domain are specified, will default to current user/domain. Types, |
In the hash, keys are set to colon-sparated $uname,$udom,and $role, |
| roles, and roledoms are references to arrays, of role statuses |
and value is set to colon-separated start and end times for the role. |
| (active, future or previous), roles (e.g., cc,in, st etc.) and domains |
If no username and domain are specified, will default to current |
| of the roles which can be used to restrict the list if roles |
user/domain. Types, roles, and roledoms are references to arrays, |
| reported. If no array ref is provided for types, will default to |
of role statuses (active, future or previous), roles |
| return only active roles. |
(e.g., cc,in, st etc.) and domains of the roles which can be used |
| |
to restrict the list of roles reported. If no array ref is |
| |
provided for types, will default to return only active roles. |
| |
|
| =back |
=back |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl