File Coverage

blib/lib/HTTP/Server/Simple/Er.pm

Criterion	Covered	Total	%
statement	72	143	50.3
branch	8	38	21.0
condition	0	15	0.0
subroutine	19	28	67.8
pod	10	10	100.0
total	109	234	46.5

package HTTP::Server::Simple::Er;
$VERSION = v0.0.4;

use warnings;
use strict;
use Carp;

use HTTP::Headers ();
use HTTP::Date ();
use HTTP::Status ();

use URI::Escape ();

=head1 NAME

HTTP::Server::Simple::Er - lightweight server and interface

=head1 SYNOPSIS

  use HTTP::Server::Simple::Er;
  HTTP::Server::Simple::Er->new(port => 8089,
    req_handler => sub {
      my $self = shift;
      my $path = $self->path;
      ...
      $self->output(404, "can't find it");
    }
  )->run;

=head1 ABOUT

This is mostly an API experiment.  You might be perfectly happy with
HTTP::Server::Simple, but I find that I often want to use it only in
tests and that the interface is a little clunky for that, so I'm
gathering some of the handiness that has been sitting on my hard drive
and starting to get it on CPAN.

=cut

my @PROPS = qw(method protocol query_string
  request_uri path localname localport peername peeraddr);
use Class::Accessor::Classy;
with 'new';
ri 'listener_cb';
rw @PROPS;
ri 'port';
ri 'req_handler';
ro 'headers';
ri 'child_pid';
no  Class::Accessor::Classy;

# ick, make our accessors overwrite those
use base; base->import('HTTP::Server::Simple');

=head2 new

  my $server = HTTP::Server::Simple::Er->new(%props);

=cut

sub new {
  my $class = shift;
  croak('odd number of elements in argument list') if(@_ % 2);
  my $self = {@_};
  bless($self, $class);
  return($self);
} # end subroutine new definition
########################################################################

=begin internals

=head2 run

  $server->run;

=cut

sub run {
  my $self = shift;
  $self->set_port(8080) unless($self->port);
  $self->SUPER::run(@_);
} # end subroutine run definition
########################################################################

=head2 setup_listener

Used by child_server() to callback once we're setup.

  $server->setup_listener;

=cut

sub setup_listener {
  my $self = shift;
  $self->SUPER::setup_listener;
  if(my $cb = $self->listener_cb) {
    $cb->();
  }
} # end subroutine setup_listener definition
########################################################################

=head2 setup

  $self->setup(%blah);

=cut

sub setup {
  my $self = shift;
  while(my ($item, $value) = splice(@_, 0, 2)) {
    my $setter = 'set_' . $item;
    $self->$setter($value);
  }
} # end subroutine setup definition
########################################################################

=head2 headers

  $self->headers($ref);

=cut

sub headers {
  my $self = shift;
  my ($ref) = @_;
  $ref or return($self->{headers});
  my %headers = @$ref;
  my $h = $self->{headers} = HTTP::Headers->new;
  while(my ($k, $v) = each(%headers)) {
    $h->header($k, $v);
  }
} # end subroutine headers definition
########################################################################

=end internals

=head2 child_server

Starts the server as a child process.

  my $url = $server->child_server;

=cut

sub child_server {
  my $self = shift;

  my $parent = $$;
  my $win_event;
  my $child;
  my $cb;
  my $kill_child;
  if($^O eq 'MSWin32') {
    require Win32::Event;
    $win_event = Win32::Event->new();
    $kill_child = sub { kill 9, $child; sleep 1 while kill 0, $child; };
    $cb = sub {$win_event->pulse};
  }
  else {
    $kill_child = sub { kill INT => $child; };
    $cb = sub {kill USR1 => $parent};
  }
  $self->set_listener_cb($cb);

  my $child_loaded = 0;
  local %SIG;
  if(not $^O eq 'MSWin32') {
    $SIG{USR1} = sub { $child_loaded = 1; };
  }

  local *print_banner = sub {}; # silence this thing

  $self->set_port(8080) unless($self->port);
  $child = $self->background;
  $child =~ /^-?\d+$/ or
    croak("background() didn't return a valid pid");
  $self->set_child_pid($child);

  # hooks to handle our zombies:
  $SIG{INT} = sub { # TODO should really be stacked handlers?
    warn "interrupt";
    $kill_child->();
    # rethrow:  INT *shouldn't* run END blocks => exit/die is wrong
    $SIG{INT} = 'DEFAULT'; kill INT => $$;
  };
  eval(q(END {&$kill_child}));

  if($win_event) {
    $win_event->wait;
  }
  else {
    local $SIG{CHLD} = sub { croak "child died"; };
    1 while(not $child_loaded);
  }
  return("http://localhost:" . $self->port);
} # end subroutine child_server definition
########################################################################

=head2 handler

You may override this, or simply set C before calling run.

  $server->handler;

=cut

sub handler {
  my $self = shift;
  my $h = $self->req_handler or
    croak("req_handler not defined or overridden");
  $h->($self);
} # end subroutine handler definition
########################################################################

=head2 output

Takes status code from $params{status} or a leading number.  Otherwise,
sets it to 200.

  $self->output(\%params, @strings);

  $self->output(501, \%params, @strings);

  $self->output(501, @strings);

  $self->output(@strings);

The code may also be an 'RC_*' string which corresponds to a constant
from HTTP::Status.

  $self->output(RC_NOT_FOUND => @error_html);

=cut

sub output {
  my $self = shift;
  my @args = @_;

  # allow leading code and/or leading params ref
  my $code = ($args[0] =~ m/^RC_|^\d\d\d$/) ? shift(@args) : undef;
  my %p;
  if((ref($args[0])||'') eq 'HASH') {
    %p = %{shift(@args)};
    ($code and $p{status}) and die "cannot have status twice"
  }
  # let subclasses pass a trailing hashref
  if(((ref($args[-1]))||'') eq 'HASH') {
    my $also = pop(@args);
    my @k = keys(%$also);
    @p{@k} = @$also{@k};
  }
  $code = $p{status} ||= $code ||= 200;
  if($code =~ m/^RC_/) {
    my $sub = HTTP::Status->can($code) or
      croak("$code is not a valid RC_* constant in HTTP::Status");
    $p{status} = $code = $sub->();
  }

  # "servers MUST include a Date header"
  $p{Date} ||= HTTP::Date::time2str(time);

  my $h = HTTP::Headers->new(%p);
  $h->content_type('text/html') unless($h->content_type);

  my $data = join("\r\n", @args);
  $h->content_length(length($data));

  my $message = HTTP::Status::status_message($code);
  print join("\r\n",
    "HTTP/1.1 $code $message",
    $h->as_string, '');
  print $data;
} # end subroutine output definition
########################################################################

=head2 params

Return a hash of parameters parsed from $self->query_string;

  my %params = $server->params;

=cut

sub params {
  my $self = shift;

  my $s = $self->query_string;
  # XXX check for correctness
  return map({URI::Escape::uri_unescape($_)}
    map({split(/=/, $_, 2)} split(/&/, $s)));
} # params #############################################################

=head2 form_data

Retrieve POSTed form data.  If an element is mentioned twice, its value
automatically becomes an arrayref.

  my %form = $server->form_data;

=cut

sub form_data {
  my $self = shift;

  my $h = $self->headers;
  my $s;
  my $fh = $self->stdio_handle;
  read($fh, $s, $h->{'content-length'});

  # XXX check for correctness
  my %d;
  foreach my $pair (split(/&/, $s)) {
    my ($k,$v) = map({$_ = URI::Escape::uri_unescape($_); s/\+/ /g; $_}
      split(/=/, $pair, 2));
    if($d{$k}) {
      $d{$k} = [$d{$k}] unless(ref $d{$k});
      push(@{$d{$k}}, $v);
    }
    else {
      $d{$k} = $v;
    }
  }
  return(%d);
} # form_data ##########################################################

=head1 AUTHOR

Eric Wilhelm @

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatsoever.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# vi:ts=2:sw=2:et:sta
1;