view release on metacpan or  search on metacpan

RandomLocation.pm  view on Meta::CPAN

package Apache::RandomLocation;

use strict;
use vars qw($VERSION);

use Apache::Constants qw(OK DECLINED REDIRECT SERVER_ERROR);
use CGI qw(:html2 start_form end_form submit param popup_menu);
$VERSION = '0.5';

sub handler {
  my ($r) = shift;

# determine the type requested and path information, if applicable
# $mirror will uniquely identify the <Location> directive
  my $mirror = $r->location;
  my $uri = $r->uri;
  (my $request = $uri) =~ s!$mirror(.*)!$1!;

# get ConfigFile, Type, and BaseUrl variables from PerlSetVar
  my ($configfile, $type, $site_info);


  $type = lc $r->dir_config("Type") || 'file';
  if ( $type !~ /^(file|mirror)$/ ) {
    $r->log_error("Type variable $type not recognized");
    return SERVER_ERROR;
  }

  $configfile = $r->dir_config('ConfigFile') || '';
  if ($configfile =~ m!^~!) {
    (my $home = $request) =~ s!(.*)/[^/]+!$1!;
    my $home_dir = $r->lookup_uri($home)->filename;
    $configfile =~ s!^~!$home_dir!;
    $mirror = $uri;
  }
  if ( ($type eq "mirror") and (!$configfile) ) {
    $r->log_error("A configuration file must be specified for Type mirror");
    return SERVER_ERROR;
  }

  my $baseurl = $r->dir_config('BaseURL') || '/';
  $baseurl .= "/" unless substr($baseurl, -1, 1) eq '/';

  # get the real directory from $baseurl, assuming $baseurl
  # points to a directory on the local server
  my $local_server = $r->server->server_hostname;
  my $dir;
  if ($baseurl =~ m!^~!) {
    (my $home = $request) =~ s!(.*)/[^/]+!$1!;
    $baseurl =~ s!^~!$home!;
    $dir = $r->lookup_uri($baseurl)->filename;
    $mirror = $uri;
  }
  elsif ($baseurl !~ m!^http://!) {
    $dir = $r->lookup_uri($baseurl)->filename;
  }
  elsif ($baseurl =~ m!^http://$local_server!) {
    (my $local_base = $baseurl) =~ s!^http://$local_server(.*)!$1!;
    $local_base = '/' unless ($local_base =~ m!^/!);
    $dir = $r->lookup_uri($local_base)->filename;
  }
  else {
    $dir = '';
  }

# if $main::Apache::RandomLocation::site_info doesn't exist, create it,
# using $mirror to unizuely identify it, based on the <Location> directive
  if (! $main::Apache::RandomLocation::site_info{$mirror} ) {
    unless ( read_config($r, $type, $mirror, $dir, $configfile) ) {
      $r->log_error("An error occurred in reading $configfile");
      return SERVER_ERROR;
    } 
  }
# set $site_info
  unless ($site_info = $main::Apache::RandomLocation::site_info{$mirror} ) {
    $r->log_error("Can't read \$main::Apache::RandomLocation::site_info{\$mirror}: $!");
    return SERVER_ERROR;
  }

# if param('site') exists, it came from a manual selection,
# so redirect the user there
  if ( param('site') ) {
    my $site = param('site');
    my $url = "$site_info->{$site}[0]$site/$site_info->{$site}[2]/";

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

    $r->send_cgi_header("Location: ${url}\015\012\015\012");
    return OK;
  }

# if the following is satisfied, the user wants a list of locations.
# Present a form with those listed
  elsif (  ($type eq 'mirror') and (! $request) ) {
    
    # get the host name, so the default site is one nearby
    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 $default = get_site($country_code, $site_info);
    my @list =  # order the list by country code, then alphebetically
      map { $_->[0] }  
    sort { $a->[1] cmp $b->[1] or $a->[0] cmp $b->[0] } 
    map { [ $_, /.*\.(\w+)$/] }  
    keys %{$site_info};
    
    # output the form
    $r->print(start_html('-title' => 'Manual selection',
			 '-dtd' => '-//W3C//DTD HTML 3.2//EN',
			 'BGCOLOR' => '#FFFFFF',
			 'TEXT' => '#OOOOOO',
			 'LINK' => '#0000FF',
			 'VLINK' => '#000080',
			 'ALINK' => '#FF0000'),
	      h2('Manual Selection'),
	      start_form(),
	      "From this page, you can manually choose a site: ",
	      p,
	      popup_menu( '-name' => 'site',
			  '-values' => \@list,
			  '-default' => $default), 
	      p, 
	      submit('-value' => "Select site"),
	      end_form(),
	      end_html()
	     );

    
  }

# the user has specified a file or location request
  else {
    
    my $url;
    
    if ( $type eq 'file' ) {
      my $file = $site_info->[ int rand @{$site_info} ];
      $url = ($baseurl =~ m!^http://!) ? "${baseurl}${file}" : "http://${local_server}${baseurl}${file}";
# redirect the client
#      $r->send_cgi_header("Location: ${baseurl}${file}\015\012\015\012");
#      return REDIRECT;
# Instead of the preceding two lines, the following can be used.
# This saves one request to the server.

      $r->internal_redirect_handler("${baseurl}${file}");
      return OK;
    }

    else {
      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 {