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

  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;

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

  my $url = $server->child_server;

  $server->handler;

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

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

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

  $self->output(@strings);

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

  my %params = $server->params;

  my %form = $server->form_data;

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 ();

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');

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
########################################################################

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

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

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

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
########################################################################

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
########################################################################

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

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
########################################################################

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 #############################################################

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 ##########################################################

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