[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.848 and 1.857

version 1.848, 2007/03/14 23:36:10 version 1.857, 2007/04/03 00:49:14
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 7404  sub hreflocation { Line 7426  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 7417  sub current_machine_domains { Line 7443  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 7558  sub goodbye { Line 7589  sub goodbye {
 }  }
   
 BEGIN {  BEGIN {
   
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
     unless ($readit) {      unless ($readit) {
 {  {
Line 7565  BEGIN { Line 7597  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 7583  BEGIN { Line 7631  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'} );
  }   }
     }      }
     close ($fh);      
       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;
       }
   
     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 7605  BEGIN { Line 7665  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 7661  BEGIN { Line 7745  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;
Line 7674  BEGIN { Line 7762  BEGIN {
   
 {   { 
     my %iphost;      my %iphost;
       my %name_to_ip;
       my %lonid_to_ip;
     sub get_hosts_from_ip {      sub get_hosts_from_ip {
  my ($ip) = @_;   my ($ip) = @_;
  my %iphosts = &get_iphost();   my %iphosts = &get_iphost();
Line 7682  BEGIN { Line 7772  BEGIN {
  }   }
  return;   return;
     }      }
   
       sub get_host_ip {
    my ($lonid) = @_;
    if (exists($lonid_to_ip{$lonid})) {
       return $lonid_to_ip{$lonid};
    }
    my $name=&hostname($lonid);
       my $ip = gethostbyname($name);
    return if (!$ip || length($ip) ne 4);
    $ip=inet_ntoa($ip);
    $name_to_ip{$name}   = $ip;
    $lonid_to_ip{$lonid} = $ip;
    return $ip;
       }
           
     sub get_iphost {      sub get_iphost {
  if (%iphost) { return %iphost; }   if (%iphost) { return %iphost; }
  my %name_to_ip;  
  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 7701  BEGIN { Line 7804  BEGIN {
     } else {      } else {
  $ip = $name_to_ip{$name};   $ip = $name_to_ip{$name};
     }      }
       $lonid_to_ip{$id} = $ip;
     push(@{$iphost{$ip}},$id);      push(@{$iphost{$ip}},$id);
  }   }
  return %iphost;   return %iphost;
Removed from v.1.848  
changed lines
  Added in v.1.857

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>