package ServerApp; use strict; use HTTP::Daemon; use HTTP::Status; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); $VERSION = ".001"; ## not only PRE-ALPHA code, but SPECULATIVE, EXPERIMENTAL probing in the dark at a possibly original concept - go easy. use constant DEBUG => 0; use constant DEBUG_BASIC => 0; sub new { my $self = shift; my ($args) = @_; #use Data::Dumper; print Dumper($args); die "Need a port" if !$args->{Port}; $self = {}; $self->{'_async'} = $args->{_async} ? 1 : 0; $self->{'_daemon'} = new HTTP::Daemon( LocalAddr => '127.0.0.1', LocalPort => $args->{Port}, ); $self->{'_handlers'} = $args->{With} ? $args->{With} : [] ; return bless($self, 'ServerApp'); } sub run_with { my $self = shift; my @paths = @_; return $self->_run(@paths); } sub daemon { return $_[0]->{'_daemon'} } sub async { return $_[0]->{'_async'} } sub handlers { return $_[0]->{'_handlers'} } sub _run { my $self = shift; my @paths = @_; unshift(@paths, @{ $self->handlers }); my $d = $self->daemon; print " ready @: url, ">\n" if DEBUG_BASIC; while (my $c = $d->accept) { my $r = $c->get_request; if ($r) { print "REQUEST: " . Dumper($r) . "" if DEBUG_BASIC; my $res = new HTTP::Response( 200, "OK" ); my $result = handleRequest($r, @paths); if( $result->{content} ) { $res->header( -content_type => "text/html" ); $res->content( $result->{content} ); } elsif( $result->{js} ) { use Data::JavaScript::Anon; $res->header( -content_type => " application/x-javascript" ); $res->content( Data::JavaScript::Anon->anon_dump($result->{js}) ); } $c->send_response($res); if( exists $result->{exit_with} ) { $c = undef; # close connection return $result->{exit_with}; } #~ print "FOUR OH FOUR\n"; #~ #$c->send_error(RC_FORBIDDEN); print " --------------------------\n" if DEBUG_BASIC; } $c = undef; # close connection } } sub handleRequest { my ($req, @paths) = @_; my $result = {}; foreach( @paths ) { my ($match, $fcn, $ret) = @$_; my $info = checkIfMatches($req, $match); if( DEBUG ) { use Data::Dumper; print $req->url->path . " vs. " . Dumper($match) . " = " . ($info ? "(yes): " . Dumper($info) . "\n" : "(no)\n\n"); } next unless $info; if( ref($fcn) eq 'CODE') { $result = &$fcn($req, $info); } else { $result = $fcn; } if( ref($result) eq '' ) { $result = { content => $result }; } if( DEBUG ) { use Data::Dumper; print Dumper( $result ); } if( $ret ) { if( ref($ret) eq 'CODE') { $result->{exit_with} = &$ret($req); } else { $result->{exit_with} = $ret; } print "Will exit with $result->{exit_with}" if( DEBUG ) ; } return $result; } if( DEBUG ) { print "404\n\n"; } return { content=> "404:\n" . Dumper($req) }; } sub checkIfMatches { my ($req, $match) = @_; my $ref = ref($match); print "\tChecking a " . ($ref ne '' ? $ref : "String($match)") . " against: " . $req->url->path . "..\n" if DEBUG; if( $ref eq 'Regexp' ) { if( $req->url->path =~ $match ) { return { type => $ref, matches => [$req->url->path, $1, $2, $3, $4, $5, $6, $7, $8, $9] }; } } elsif( $ref eq 'CODE') { my $r = &$match($req); print "\t\t\treturned: " . Dumper($r) . "\n" if DEBUG; if( $r ) { return { type => $ref, value => $r }; } } elsif( $ref eq 'ARRAY') { #any of, or all of these? anyway to indicate one or the other? foreach( @$match ) { my $v = checkIfMatches($req, $_); return { type => $ref, matched => $_, result => $v } if $v; } } elsif( $ref eq 'HASH') { return { type => $ref, value => $match->{$req} } if exists($match->{$req}); } elsif( $ref eq '') { return { type => $ref, value => 1 } if $req->url->path =~ /^\/?$match$/; } else { warn "Unknown ref(): $ref"; } return undef; } 1;