/[Frey]/trunk/lib/Frey/Server.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /trunk/lib/Frey/Server.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 653 - (hide annotations)
Sun Nov 30 23:49:32 2008 UTC (15 years, 5 months ago) by dpavlin
File size: 3577 byte(s)
first request_url cleanup
1 dpavlin 19 package Frey::Server;
2 dpavlin 2
3 dpavlin 55 use Moose;
4 dpavlin 627 extends 'Frey::Editor';
5 dpavlin 341 with 'Frey::Config';
6 dpavlin 100
7 dpavlin 2 use Data::Dump qw/dump/;
8    
9 dpavlin 223 use Frey::Run;
10 dpavlin 23
11 dpavlin 627 has 'port' => (
12     documentation => 'port on which server listen',
13     is => 'ro',
14     isa => 'Int',
15     default => sub {
16     my $self = shift;
17     $ENV{FREY_PORT} || $self->config->{port} || 16001
18     },
19     );
20 dpavlin 2
21 dpavlin 627 has 'editor' => (
22     is => 'ro',
23     isa => 'Frey::Editor',
24     lazy => 1,
25     default => sub {
26     Frey::Editor->new;
27     },
28     );
29 dpavlin 2
30 dpavlin 627 =head2 request
31 dpavlin 37
32 dpavlin 627 This is simple dispatcher for our server. Currently it's in flux and
33     documented only in source code.
34 dpavlin 182
35     =cut
36    
37 dpavlin 627 sub print {
38     my $self = shift;
39 dpavlin 628 warn "# print ", join(' ', map { length $_ } @_ );
40     $self->{_print}->( @_ );
41 dpavlin 25 }
42 dpavlin 2
43 dpavlin 627 sub request {
44     my ( $self, $url, $params ) = @_;
45 dpavlin 182
46 dpavlin 627 if ( my $ref = ref($url) ) {
47     die "url not URI but ", dump( $url ) unless $ref =~ m{^URI};
48 dpavlin 632 } else {
49 dpavlin 627 $url = URI->new($url);
50     }
51 dpavlin 182
52 dpavlin 627 my $path = $url->path;
53 dpavlin 182
54 dpavlin 653 eval {
55     # {
56 dpavlin 120
57 dpavlin 477 if ( $path =~ m{/reload(.*)} ) {
58 dpavlin 542
59     $ENV{FREY_NO_LOG} = 1;
60     my $cmd = "perl -c $0";
61 dpavlin 627 warn "# check syntax with $cmd";
62 dpavlin 542 if ( system($cmd) == 0 ) {
63 dpavlin 581 my $server = Frey::Server->new;
64 dpavlin 627 $self->load_config;
65 dpavlin 639 # Module::Reload->check;
66 dpavlin 542 warn "# reload done";
67 dpavlin 639 $self->print( refresh( $1, 0 ) );
68 dpavlin 542 return;
69     } else {
70     warn "ERROR: $?";
71     }
72     $ENV{FREY_NO_LOG} = 0;
73    
74 dpavlin 477 } elsif ( $path =~ m{/exit(.*)} ) {
75     # FIXME do we need some kind of check here for production? :-)
76     # ./bin/dev.sh will restart us during development
77 dpavlin 627 $self->print( refresh( $1, 2 ) );
78 dpavlin 477 exit;
79 dpavlin 429 }
80 dpavlin 66
81 dpavlin 429 my $html;
82 dpavlin 292
83 dpavlin 429 sub rest2class {
84     my $class = shift;
85     $class =~ s/-/::/; # sigh!
86     return $class;
87     }
88 dpavlin 277
89 dpavlin 114 my $f;
90 dpavlin 66
91 dpavlin 421 # shared run params
92     my $run = {
93 dpavlin 627 request_url => $url,
94 dpavlin 625 # debug => 1,
95 dpavlin 421 };
96    
97 dpavlin 292 if (
98     $path =~ m{/Frey[:-]+ObjectBrowser}
99     ) {
100 dpavlin 627 $f = Frey::ObjectBrowser->new( fey_class => $params->{class} );
101     # $f->request( $req );
102 dpavlin 292 } elsif (
103     $path =~ m{/Frey[:-]+ObjectDesigner}
104     ) {
105 dpavlin 627 $f = Frey::ObjectDesigner->new( fey_class => $params->{class} );
106     # $f->request( $req );
107     } elsif ( $path =~ $self->editor->url_regex ) {
108     $self->print( $self->editor->command( $path ) );
109 dpavlin 346 return;
110     } elsif (
111 dpavlin 581 $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}
112 dpavlin 292 ) {
113     my $class = rest2class $1;
114 dpavlin 421 warn "# run $path -> $class $2";
115     $run->{format} = $3 if $3;
116 dpavlin 627 $run->{$_} = $params->{$_} foreach keys %$params;
117 dpavlin 653 $f = Frey::Run->new( class => $class, params => $run, run => $2 );
118 dpavlin 292 } elsif (
119     $path =~ m{/([^/]+)/?$}
120     ) {
121     my $class = rest2class $1;
122     warn "# introspect $class";
123 dpavlin 625 $run->{class} ||= $class;
124 dpavlin 653 $f = Frey::Run->new( class => 'Frey::Introspect', params => $run );
125 dpavlin 121 } else {
126 dpavlin 653 $f = Frey::Run->new( class => 'Frey::ClassBrowser', params => $run );
127 dpavlin 66 }
128    
129 dpavlin 277 if ( $f ) {
130 dpavlin 519 $f->clean_status;
131 dpavlin 627 # $f->add_status( { request => $req } );
132 dpavlin 581 $f->status_parts;
133     if ( my $html = $f->html ) {
134     warn "## html ",length($html)," bytes";
135 dpavlin 627 $self->print( $html );
136 dpavlin 581 } else {
137 dpavlin 589 confess "no output from $f";
138 dpavlin 581 }
139 dpavlin 277 } else {
140 dpavlin 589 confess "# can't call request on nothing!";
141 dpavlin 277 }
142    
143 dpavlin 66 };
144    
145     if ( $@ ) {
146 dpavlin 581 warn "SERVER ERROR: $@";
147     # $req->conn->send_error( 404 ); # FIXME this should probably be 500, but we can't ship page with it
148 dpavlin 627 $self->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );
149 dpavlin 190 # Carp::REPL::repl;
150 dpavlin 53 }
151    
152 dpavlin 2 }
153    
154 dpavlin 581 sub refresh {
155     my ( $url, $time ) = @_;
156     $url ||= '/';
157 dpavlin 643 $time ||= 0;
158 dpavlin 581 warn "# refresh $url";
159     qq|
160     <html>
161     <head>
162     <META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
163     </head>
164     <body>
165     Refresh <a href="$url"><tt>$url</tt></a> in $time sec
166     </body>
167     </html>
168     \n\r\n\r
169     |; # XXX newlines at end are important to flush content to browser
170     }
171    
172 dpavlin 25 1;

  ViewVC Help
Powered by ViewVC 1.1.26