File Coverage

blib/lib/POE/Component/Server/SimpleContent.pm

Criterion	Covered	Total	%
statement	182	235	77.4
branch	51	94	54.2
condition	21	54	38.8
subroutine	30	34	88.2
pod	11	12	91.6
total	295	429	68.7

package POE::Component::Server::SimpleContent;

# We export some stuff
require Exporter;
@ISA = qw( Exporter );
@EXPORT = qw(generate_301 generate_404 generate_403);

use strict;
use warnings;
use Carp;
use POE qw( Wheel::ReadWrite Filter::Stream );
use CGI qw(:standard);
use URI::Escape;
use Filesys::Virtual::Plain;
use MIME::Types;
use Storable;
use File::Basename;
use vars qw($VERSION);

$VERSION = '1.14';

sub spawn {
  my $package = shift;
  croak "$package needs an even number of parameters" if @_ & 1;
  my %params = @_;

  $params{lc $_} = delete $params{$_} for keys %params;

  die "$package requires a 'root_dir' argument\n"
	unless $params{root_dir} and -d $params{root_dir};

  _massage_handlers( $params{handlers} ) if $params{handlers};
  $params{handlers} = { } unless $params{handlers};

  my $options = delete $params{'options'};

  my $self = bless \%params, $package;

  $self->{vdir} = Filesys::Virtual::Plain->new( { root_path => $self->{root_dir} } )
	or die "Could not create a Filesys::Virtual::Plain object for $self->{root_dir}\n";

  $self->{mt} = MIME::Types->new();

  $self->{auto_index} = 1 unless defined ( $self->{auto_index} ) and $self->{auto_index} == 0;
  $self->{index_file} = 'index.html' unless $self->{index_file};

  $self->{prefix_fix} = delete $self->{alias_path} if $self->{alias_path};

  $self->{prefix_fix} = quotemeta( $self->{prefix_fix} ) if $self->{prefix_fix};

  my $mm;

  eval {
	require File::MMagic::XS;
	import File::MMagic::XS qw(:compat);
	$mm = File::MMagic::XS->new();
  };

  eval {
	require File::MMagic;
	$mm = File::MMagic->new();
  } unless $mm;

  $self->{mm} = $mm;

  $self->{session_id} = POE::Session->create(
	object_states => [
		$self => {
               request  => '_request',
			   shutdown => '_shutdown',
              -input    => '_read_input',
              -error    => '_read_error',
		},
		$self => [ qw(_start) ],
	],
	( ( defined ( $options ) and ref ( $options ) eq 'HASH' ) ? ( options => $options ) : () ),
  )->ID();

  return $self;
}

sub _start {
  my ($kernel,$self) = @_[KERNEL,OBJECT];

  $self->{session_id} = $_[SESSION]->ID();

  if ( $self->{alias} ) {
	$kernel->alias_set( $self->{alias} );
  } else {
	$kernel->refcount_increment( $self->{session_id} => __PACKAGE__ );
  }

  return;
}

sub request {
  my $self = shift;
  $poe_kernel->post( $self->session_id() => 'request' => @_ );
}

sub _request {
  my ($kernel,$self,$request,$response) = @_[KERNEL,OBJECT,ARG0 .. ARG1];
  my $sender = $_[SENDER]->ID();

  # Sanity check the $request and $response objects *sigh*
  return unless $response and $response->isa("HTTP::Response");

  unless ( $request and $request->isa("HTTP::Request") ) {
	$kernel->post( $sender => 'DONE' => $response );
	return;
  }

  my $path = uri_unescape( $request->uri->path );
  my $realpath = $path;

  $realpath = $self->{prefix_path} . $path if $self->{prefix_path};
  $realpath =~ s/^$self->{prefix_fix}// if $self->{prefix_fix};

  SWITCH: {
    if ( $self->{vdir}->test('d', $realpath) ) {
	if ( $path !~ /\/$/ ) {
	  $path .= '/';
	  $response = $self->_generate_301( $path, $response );
	  last SWITCH;
	}
	if ( $self->{auto_index} and !$self->{vdir}->test('e', $realpath . $self->{index_file} ) ) {
	  $response = $self->_generate_dir_listing( $path, $response );
	  last SWITCH;
	}
	if ( $self->{vdir}->test('e', $realpath . $self->{index_file} ) ) {
	  my ($filename, $directory, $suffix) = fileparse($self->{index_file}, keys %{ $self->{handlers} } );
	  if ( $suffix ) {
	     $kernel->post(
		$self->{handlers}->{ $suffix }->{SESSION},
		$self->{handlers}->{ $suffix }->{EVENT},
		{
			request         => $request,
			response        => $response,
			session         => $sender,
			script_name     => $path . $self->{index_file},
			script_filename => $self->{vdir}->root_path() . $realpath . $self->{index_file},
		},
	     );
	     return;
	  }
	  $response = $self->_generate_content( $sender, $path . $self->{index_file}, $response );
	  last SWITCH;
	}
	$response = $self->_generate_403( $response );
	last SWITCH;
    }
    if ( $self->{vdir}->test('e', $realpath) ) {
	my ($filename, $directory, $suffix) = fileparse($realpath, keys %{ $self->{handlers} } );
	if ( $suffix ) {
	   $kernel->post(
		$self->{handlers}->{ $suffix }->{SESSION},
		$self->{handlers}->{ $suffix }->{EVENT},
		{
			request         => $request,
			response        => $response,
			session         => $sender,
			script_name     => $path,
			script_filename => $self->{vdir}->root_path() . $realpath,
		},
	   );
	   return;
	}
	$response = $self->_generate_content( $sender, $path, $response );
	last SWITCH;
    }
    $response = $self->_generate_404( $response );
  }

  $kernel->post( $sender => 'DONE' => $response ) if defined $response;
  undef;
}

sub shutdown {
  my $self = shift;
  $poe_kernel->post( $self->session_id() => 'shutdown' => @_ );
}

sub _shutdown {
  my ($kernel,$self) = @_[KERNEL,OBJECT];

  if ( $self->{alias} ) {
	$kernel->alias_remove( $_ ) for $kernel->alias_list();
  } else {
	$kernel->refcount_decrement( $self->{session_id} => __PACKAGE__ );
  }
  undef;
}

sub session_id {
  return $_[0]->{session_id};
}

# Alias for deprecated function
sub autoindex {
  warn "autoindex is deprecated: please use auto_index";
  goto &auto_index;
}

sub auto_index {
  my $self = shift;
  my $value = shift;
  return $self->{auto_index} unless defined $value;
  $self->{auto_index} = $value;
}

sub index_file {
  my $self = shift;
  my $value = shift;
  return $self->{index_file} unless defined $value;
  $self->{index_file} = $value;
}

sub _generate_404 {
  my $self = shift;
  my $response = shift || return;
  return generate_404( $response );
}

sub generate_404 {
  my $response = shift || return;
  return unless $response->isa('HTTP::Response');
  $response->code( 404 );
  $response->header( 'Content-Type', 'text/html' );
  $response->content( start_html('404') . h1('Not Found') . end_html );
  return $response;
}

sub _generate_403 {
  my $self = shift;
  my $response = shift || return;
  return generate_403( $response );
}

sub generate_403 {
  my $response = shift || return;
  return unless $response->isa('HTTP::Response');
  $response->code( 403 );
  $response->header( 'Content-Type', 'text/html' );
  $response->content( start_html('403') . h1('Forbidden') . end_html );
  return $response;
}

sub _generate_301 {
  my $self = shift;
  my $path = shift || return;
  my $response = shift || return;
  return generate_301( $path, $response );
}

sub generate_301 {
  my $path = shift || return;
  my $response = shift || return;
  return unless $response->isa('HTTP::Response');
  $response->code( 301 );
  $response->header( 'Location' => $path );
  $response->header( 'Content-Type', 'text/html' );
  $response->content( start_html('301') . h1('Moved Permanently') . 'The document has moved here.' . end_html );
  return $response;
}

sub _generate_dir_listing {
  my $self = shift;
  my $path = shift || return;
  my $response = shift || return undef;
  my $content = start_html('Index of ' . $path) . h1('Index of ' . $path) . qq{\n\n};

  my $realpath = $path;
  $realpath = $self->{prefix_path} . $path if $self->{prefix_path};
  $realpath =~ s/^$self->{prefix_fix}// if $self->{prefix_fix};

  foreach my $item ( $self->{vdir}->list( $realpath ) ) {
	next if $item =~ /^\./;
	$content .= qq{$item\n};
  }

  $content .= qq{\n} . end_html;
  $response->code( 200 );
  $response->header( 'Content-Type', 'text/html' );
  $response->content( $content );
  return $response;
}

sub _read_input {
  ${ $_[OBJECT]{read}{$_[ARG1]}{content} } .= $_[ARG0];
}

# Read finished
sub _read_error {
  my ($self, $kernel, $error, $wheelid) = @_[ OBJECT, KERNEL, ARG1, ARG3 ];
  my $read     = delete $self->{read}{$wheelid};
  my $response = delete $read->{response};
  my $content  = delete $read->{content};
  my $mimetype = delete $read->{mimetype};
  my $sender   = delete $read->{sender};

  delete $read->{wheel};

  if ($error) {
    $response->content("Internal Server Error");
    $response->code(500);
  }
  else {
	unless ( $mimetype ) {
	  if ( $self->{mm} ) {
		$mimetype = $self->{mm}->checktype_contents( $$content );
	  }
	  else {
		$mimetype = 'application/octet-stream';
	  }
	}
	$response->code( 200 );
	$response->content_type( $mimetype );
	$response->content_ref( $content );
  }

  $kernel->post( $sender => 'DONE' => $response );
}

sub _generate_content {
  my $self = shift;
  my $sender = shift || return;
  my $path = shift || return;
  my $response = shift || return;
  my $realpath = $path;
  $realpath = $self->{prefix_path} . $path if $self->{prefix_path};
  $realpath =~ s/^$self->{prefix_fix}// if $self->{prefix_fix};

  my $mimetype = $self->{mt}->mimeTypeOf( $path );

  if ( my $fh = $self->{vdir}->open_read( $realpath ) ) {
    binmode($fh);
    if ( $^O eq 'MSWin32' or $self->{blocking} ) {
      local $/ = undef;
	my $content = <$fh>;
	unless ( $mimetype ) {
	  if ( $self->{mm} ) {
		$mimetype = $self->{mm}->checktype_contents( $content );
	  }
	  else {
		$mimetype = 'application/octet-stream';
	  }
	}
	$response->code( 200 );
	$response->content_type( $mimetype );
	$response->content_ref( \$content );
    } else {
      my $readwrite = POE::Wheel::ReadWrite->new(
        Handle          => $fh,
        Filter          => POE::Filter::Stream->new(),
        InputEvent      => "-input",
        ErrorEvent      => "-error",
      );

      my $content = "";

      my $wheelid   = $readwrite->ID;
      my $readheap  = {
        wheel     => $readwrite,
        response  => $response,
        mimetype  => $mimetype,
        sender    => $sender,
        content   => \$content,
      };

      $self->{read}{$wheelid} = $readheap;

      return;
    }
  } else {
	$response = $self->_generate_404( $response );
  }

  return $response;
}

sub _massage_handlers {
  my $handler = shift || return;
  croak( "HANDLERS is not a ref to an hash!" )
	unless ref $handler and ref $handler eq 'HASH';
  foreach my $ext ( keys %{ $handler } ) {
    delete $handler->{ $ext } unless ref $handler->{ $ext } eq 'HASH';
    croak( "HANDLER for '$ext' does not have a SESSION argument!" )
	unless $handler->{ $ext }->{'SESSION'};
    croak( "HANDLER for '$ext' does not have an EVENT argument!" )
	unless $handler->{ $ext }->{'EVENT'};
    $handler->{ $ext }->{'SESSION'} = $handler->{ $ext }->{'SESSION'}->ID()
	if UNIVERSAL::isa( $handler->{ $ext }->{'SESSION'}, 'POE::Session' );
  }
  return 1;
}

sub get_handlers {
  my $self = shift;
  my $handlers = Storable::dclone( $self->{handlers} );
  return $handlers;
}

sub set_handlers {
  my $self = shift;
  my $handlers = shift || return;
  _massage_handlers( $handlers );
  $self->{handlers} = $handlers;
  return 1;
}

1;

__END__