--- trunk/lib/Frey/Server.pm 2008/11/26 00:16:30 523 +++ trunk/lib/Frey/Server.pm 2008/11/29 17:48:54 625 @@ -2,7 +2,6 @@ use Moose; extends 'Frey'; -with 'Frey::Web'; with 'Frey::Config'; use Continuity; @@ -35,20 +34,27 @@ =cut +our $editor = Frey::Editor->new; +our $port; + sub run { - my ( $self, $port ) = @_; + my ( $self ) = @_; + + $port = $ENV{FREY_PORT} || $self->config->{port} || 16001; + $server = Continuity->new( - port => $port || $self->config->{port} || 16001, + port => $port, path_session => 1, cookie_session => 'sid', callback => \&main, debug_level => 2, staticp => sub { - $_[0]->url =~ m{^/(static|var).*\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$} + $_[0]->url =~ m{^/+(static|var).*\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$} }, ); $Module::Reload::Debug = 1; # auto if debug_level > 1 Frey::ClassLoader->new->load_all_classes(); + $editor->switch_screen if $ENV{FREY_SWITCH_SCREEN}; $server->loop; } @@ -62,36 +68,39 @@ sub main { my ($req) = @_; - my $path = $req->request->url->path; +# $req->send_headers("X-Frey-VERSION: $Frey::VERSION"); - eval { + my $path = $req->request->url->path; - sub refresh { - my $url = shift || '/'; - warn "# refresh $url"; - qq| - -
- - - - Refresh $url - - - \n\r\n\r - |; # XXX newlines at end are important to flush content to browser - } +# eval { + { if ( $path =~ m{/reload(.*)} ) { - Frey::Server->new->load_config; - Module::Reload->check; - warn "# reload done"; - $req->print( refresh( $1 ) ); - return; + + $ENV{FREY_NO_LOG} = 1; + my $cmd = "perl -c $0"; + warn "# check config with $cmd"; + if ( system($cmd) == 0 ) { + $req->print( "\r\n" ); + my $server = Frey::Server->new; + $server->load_config; + $req->print( "\r\n" ); + Module::Reload->check; + $req->print( "\r\n" ); + $req->print( refresh( $1, 1 ) ); + $req->print( "\r\n" ); + warn "# reload done"; + return; + } else { + warn "ERROR: $?"; + } + $ENV{FREY_NO_LOG} = 0; + } elsif ( $path =~ m{/exit(.*)} ) { # FIXME do we need some kind of check here for production? :-) # ./bin/dev.sh will restart us during development - $req->print( refresh( $1 ) ); + $req->print( refresh( $1, 2 ) ); + $req->print( "\r\n" ); exit; } @@ -109,12 +118,10 @@ my $f; - my $editor = Frey::Editor->new; - # shared run params my $run = { request_url => $req->request->url, - debug => 1, +# debug => 1, }; if ( @@ -129,44 +136,48 @@ $f->request( $req ); } elsif ( $path =~ $editor->url_regex ) { $req->print( $editor->command( $path ) ); - system( $editor->command( $path ) ); return; } elsif ( - $path =~ m{/([^/]+)/(as_\w+)/?([^/]+)?} + $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?} ) { my $class = rest2class $1; warn "# run $path -> $class $2"; $run->{format} = $3 if $3; $params{request_url} = $req->request->url; - $f = Frey::Run->new( class => $class, params => \%params, run => $2, %$run ); + $req->print( "\r\n\r\n" ); # send something to browser so we don't time-out + $run->{$_} = $params{$_} foreach keys %params; + $f = Frey::Run->new( class => $class, params => $run, run => $2, request_url => $req->request->url ); } elsif ( $path =~ m{/([^/]+)/?$} ) { my $class = rest2class $1; warn "# introspect $class"; - $f = Frey::Run->new( class => 'Frey::Introspect', params => { class => $class }, %$run ); + $run->{class} ||= $class; + $f = Frey::Run->new( class => 'Frey::Introspect', params => $run, request_url => $req->request->url ); } else { - $f = Frey::Run->new( class => 'Frey::ClassBrowser', %$run ); + $f = Frey::Run->new( class => 'Frey::ClassBrowser', params => $run, request_url => $req->request->url ); } if ( $f ) { $f->clean_status; $f->add_status( { request => $req } ); - warn "## status ", dump( map { keys %$_ } $f->status ); - my $html = $f->html; - die "no html output" unless $html; - warn "## html ",length($html)," bytes"; - $req->print( "$html\n" ); + $f->status_parts; + if ( my $html = $f->html ) { + warn "## html ",length($html)," bytes"; + $req->print( $html ); + } else { + confess "no output from $f"; + } } else { - warn "# can't call request on nothing!"; + confess "# can't call request on nothing!"; } }; if ( $@ ) { - warn $@; - $req->conn->send_error( 404 ); # FIXME this should probably be 500, but we can't ship page with it - $req->print( qq{$@} ); + warn "SERVER ERROR: $@"; +# $req->conn->send_error( 404 ); # FIXME this should probably be 500, but we can't ship page with it + $req->print( qq{$@\r\n\r\n} ); # Carp::REPL::repl; } @@ -180,7 +191,8 @@ send_message($req); } - if ($req->conn ) { + if ( $req->conn ) { + $req->print( "\r\n" ); # flush $req->conn->close; warn "## close connection: $@"; } @@ -223,4 +235,22 @@ } } +sub refresh { + my ( $url, $time ) = @_; + $url ||= '/'; + $time ||= 1; + warn "# refresh $url"; + qq| + + + + + + Refresh $url in $time sec + + + \n\r\n\r + |; # XXX newlines at end are important to flush content to browser +} + 1;