view release on metacpan or  search on metacpan

RandomLocation.pm  view on Meta::CPAN

      my $host = lc $r->get_remote_host;
      if (( ! $host ) or ( $host =~ /^\d+\.\d+\.\d+\.\d+$/ )) {
	my $ip = $r->connection->remote_ip;
	$host = lc host_name($ip) || 'localhost';
      }
      my $country_code = country_code($host);
      my $site = get_site($country_code, $site_info);
      $url = "$site_info->{$site}[0]$site/$site_info->{$site}[2]${request}";
# redirect the client
      $r->send_cgi_header("Location: ${url}\015\012\015\012");
      return REDIRECT;
    }

# for testing purposes
#    $r->send_http_header;
#   $r->print($url);
#    return OK;

    
  }

}

# gets the country code, based on the domain name
sub country_code {
  my ($country_code) = @_;
  if (( $country_code =~ /^\d+\.\d+\.\d+\.\d+$/) or ($country_code !~ /\./) ){
    $country_code = '(com|edu|net|org|us)';
  }
  else {
    $country_code =~ s/.*\.(\w+)$/$1/;
    if (lc $country_code =~ /^(com|edu|net|org|us)$/) {
      $country_code = '(com|edu|net|org|us)';
    }
  }
  return $country_code;
}

# searches through all the available sites, and chooses a random
# one nearby. If one doesn't exist, a random site with country code
#  /^(com|edu|net|org|us)$/ is chosen
sub get_site {
  my ($country_code, $site_info) = @_;
  my (@sites, @all_sites);
  foreach my $host ( keys %{$site_info} ) {
    push @sites, $host if ($site_info->{$host}[1] =~ /^$country_code$/);
    if (!@sites) {
      push @all_sites, $host if ($site_info->{$host}[1] =~ /^(com|edu|net|org|us)$/);
    }
  }
  my $site;
  if (@sites) {
    $site = $sites[rand(@sites)];
  } 
  else {
    $site = $all_sites[rand(@all_sites)]
  }
  return $site;
}

# looks up the host name, if the ip address is given
sub host_name {
  my ($addr) = @_;
  my @b;
  
  if (@b = ($addr =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/)) {
    return scalar gethostbyaddr(pack('C4', @b), 2);
  }
  return 0;
}

# reads ConfigFile, putting the result in $site_info, which is
# then set to  $main::Apache::RandomLocation::site_info{$mirror}
# For files, $site_info is a reference to an array holding the list
# of files. For mirrors, $site_info is a reference to a hash of arrays,
# with the key being the site amd the array holding, in order, the 
# protocol, country code, and directory 
sub read_config {
  my ($r, $type, $mirror, $dir, $configfile) = @_;
  my $site_info;

  if ( ($type eq 'file') and (! $configfile) ) {
    if ( ! $dir ) {
      $r->log_error("Need to specify ConfigFile for an external BaseURL");
      return 0;
    }
    else {
      unless ( opendir(DIR, $dir)  ) {
	$r->log_error("Cannot read $dir: $!");
	return 0;
      }
      my @globs = grep {not -d and not /^\./} readdir DIR;
      unless ( closedir DIR ) {
	$r->log_error("error closing $dir: $!");
	return 0;
      }
      push @{$site_info}, @globs;
      
    }
    
  }

  else {
    
    unless ( open(FILE, $configfile)  ) {
      $r->log_error("Apache::RandomLocation: cannot read $configfile: $!");
      return 0;
    }
    my @res;
    while (<FILE>)  {
      chomp;
      next if /^\#/;
      next if /^\s*$/;
      
      if ( $type eq 'file' ) {
	my $line = (split)[0];
	if ( $line !~ m!^\s*/.*/\s*$!) {
	  push @{$site_info}, $line;
	}
	else {
	  (my $re = $_) =~ s!^\s*/(.*?)/\s*$!$1!;