lib/Frey/Mojo.pm

package Frey::Mojo;

use strict;
use warnings;

use base 'Mojo';

use MojoX::Dispatcher::Static;

use lib 'lib';
use Frey::Server;

use Data::Dump qw/dump/;

__PACKAGE__->attr(
    static => (                             
        chained => 1,                       
        default => sub { MojoX::Dispatcher::Static->new }
    )
);

sub new {
    my $self = shift->SUPER::new();

    # This app should log only errors to STDERR
    $self->log->level('error');
    $self->log->path(undef);

        warn "# home ", $self->home;

        $self->static->root( './' );

    return $self;
}


sub handler {
        my ($self, $tx) = @_;

        # XXX fake app so static dispatcher won't die on us
        {
                package Fake::App;
                use base 'Mojo::Transaction';
                sub app {
                        my $self = shift;
                        warn "## $self app ", @_;
                        $self;
                }
                sub log {
                        my $self = shift;
                        warn "## $self log ",@_;
                        return $self;
                }
                sub debug {
                        my $self = shift;
                        warn "## $self debug ",@_;
                        return $self;
                }
        }
        bless $tx, 'Fake::App';

        if ( $self->static->dispatch($tx) ) {
#               warn "# static ",dump( $tx );
                return $tx;
        }

        my $body;

        my $server = Frey::Server->new;
        $server->{_print} = sub {
                $body .= join("\n", @_);
        };

        my $url = $tx->req->url->to_string;
        my $params = $tx->req->params->to_hash;

        warn "# url $url params ",dump($params);

        my $request = $server->request( $url, $params ); # fetch body

        warn "# request ", dump( $request );

        foreach ( 'content_type', 'code' ) {
                die "missing $_" unless defined $request->{$_};
        }

=for developer

        # compatiblity with unpatched Mojo
        sub class2rest {
                my $c = shift;
                $c =~ s/::/-/gs;
                $c;
        }
        $body =~ s{(/\w+::\w+[\w:]+)}{class2rest($1)}sge;

=cut

        $tx->res->code( $request->{code} );
        $tx->res->headers->content_type( $request->{content_type} );
        $tx->res->body( $body );

        warn dump( $tx->res->headers );
        return $tx;
}

1;
1	package Frey::Mojo;
2
3	use strict;
4	use warnings;
5
6	use base 'Mojo';
7
8	use MojoX::Dispatcher::Static;
9
10	use lib 'lib';
11	use Frey::Server;
12
13	use Data::Dump qw/dump/;
14
15	__PACKAGE__->attr(
16	static => (
17	chained => 1,
18	default => sub { MojoX::Dispatcher::Static->new }
19	)
20	);
21
22	sub new {
23	my $self = shift->SUPER::new();
24
25	# This app should log only errors to STDERR
26	$self->log->level('error');
27	$self->log->path(undef);
28
29	warn "# home ", $self->home;
30
31	$self->static->root( './' );
32
33	return $self;
34	}
35
36
37	sub handler {
38	my ($self, $tx) = @_;
39
40	# XXX fake app so static dispatcher won't die on us
41	{
42	package Fake::App;
43	use base 'Mojo::Transaction';
44	sub app {
45	my $self = shift;
46	warn "## $self app ", @_;
47	$self;
48	}
49	sub log {
50	my $self = shift;
51	warn "## $self log ",@_;
52	return $self;
53	}
54	sub debug {
55	my $self = shift;
56	warn "## $self debug ",@_;
57	return $self;
58	}
59	}
60	bless $tx, 'Fake::App';
61
62	if ( $self->static->dispatch($tx) ) {
63	# warn "# static ",dump( $tx );
64	return $tx;
65	}
66
67	my $body;
68
69	my $server = Frey::Server->new;
70	$server->{_print} = sub {
71	$body .= join("\n", @_);
72	};
73
74	my $url = $tx->req->url->to_string;
75	my $params = $tx->req->params->to_hash;
76
77	warn "# url $url params ",dump($params);
78
79	my $request = $server->request( $url, $params ); # fetch body
80
81	warn "# request ", dump( $request );
82
83	foreach ( 'content_type', 'code' ) {
84	die "missing $_" unless defined $request->{$_};
85	}
86
87	=for developer
88
89	# compatiblity with unpatched Mojo
90	sub class2rest {
91	my $c = shift;
92	$c =~ s/::/-/gs;
93	$c;
94	}
95	$body =~ s{(/\w+::\w+[\w:]+)}{class2rest($1)}sge;
96
97	=cut
98
99	$tx->res->code( $request->{code} );
100	$tx->res->headers->content_type( $request->{content_type} );
101	$tx->res->body( $body );
102
103	warn dump( $tx->res->headers );
104	return $tx;
105	}
106
107	1;