/[Frey]/branches/zimbardo/lib/Frey/Web.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

Contents of /branches/zimbardo/lib/Frey/Web.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 518 - (show annotations)
Tue Nov 25 14:58:59 2008 UTC (15 years, 4 months ago) by dpavlin
Original Path: trunk/lib/Frey/Web.pm
File size: 6630 byte(s)
insert status debug all over the place, still no clean solution :-\
1 package Frey::Web;
2 use Moose::Role;
3
4 with 'Frey::Backtrace';
5
6 use Frey::Types;
7
8 use Continuity::Widget::DomNode;
9 use Data::Dump qw/dump/;
10 use Carp qw/confess cluck/;
11 use File::Slurp;
12
13 use Frey::Bookmarklet;
14 use Frey::ClassBrowser;
15 use Frey::SVK;
16
17 has 'head' => (
18 is => 'rw',
19 isa => 'ArrayRef[Str]',
20 default => sub { [ 'static/frey.css' ] },
21 );
22
23 has 'status' => (
24 is => 'rw',
25 isa => 'ArrayRef[HashRef[Str]]',
26 lazy => 1,
27 default => sub { [
28 # { 'ClassBrowser' => Frey::ClassBrowser->new( usage_on_top => 0 )->as_markup },
29 # { 'Bookmarklets' => Frey::Bookmarklet->new->as_markup },
30 ] },
31 );
32
33 has 'request_url' => (
34 is => 'rw',
35 isa => 'Uri', coerce => 1,
36 default => '/',
37 );
38
39 has 'title' => (
40 is => 'rw',
41 isa => 'Str',
42 lazy => 1,
43 default => sub {
44 my ($self) = @_;
45 ref($self);
46 },
47 );
48
49 has 'content_type' => (
50 is => 'rw',
51 isa => 'Str',
52 default => 'text/html',
53 documentation => 'Content-type header',
54 );
55
56 has 'dump_max_bytes' => (
57 is => 'rw',
58 isa => 'Int',
59 default => 4096,
60 documentation => 'Maximum dump size sent to browser before truncation',
61 );
62
63 =head2 inline_smaller_than
64
65 Inline JavaScript and CSS smaller than this size into page reducing
66 round-trips to server.
67
68 =cut
69
70 has 'inline_smaller_than' => (
71 is => 'rw',
72 isa => 'Int',
73 default => 10240,
74 );
75
76 sub dom2html {
77 # warn "## dom2html ",dump( @_ );
78 return Continuity::Widget::DomNode->create( @_ )->to_string;
79 }
80
81 sub _inline_path {
82 my ( $self, $path ) = @_;
83 -s $path < $self->inline_smaller_than;
84 }
85
86 sub _head_html {
87 my $self = shift;
88 my $out = '';
89 foreach my $path ( @{ $self->head } ) {
90 $path =~ s!^/!!;
91 if ( $path =~ m/\.js$/ ) {
92 $out .= $self->_inline_path( $path ) ?
93 qq|<!-- $path --><script type="text/javascript">\n| . read_file($path) . qq|\n</script>| :
94 qq|<script type="text/javascript" src="/$path"></script>|;
95 } elsif ( $path =~ m/\.css$/ ) {
96 $out .= $self->_inline_path( $path ) ?
97 qq|<!-- $path --><style type="text/css">\n| . read_file( $path ) . qq|\n</style>| :
98 qq|<link type="text/css" rel="stylesheet" href="/$path" media="screen">|;
99 } elsif ( $path =~ m{<.+>}s ) {
100 $out .= $path;
101 } else {
102 confess "don't know how to render $path";
103 }
104 $out .= "\n";
105 }
106 return $out;
107 }
108
109 =head2 add_head
110
111 $o->add_head( 'path/to/external.js' );
112
113 my $size = $o->add_head( 'path/to/external.css' );
114
115 $o->add_head( '<!-- html content -->' );
116
117 =cut
118
119 sub add_head {
120 my ( $self, $path ) = @_;
121 return if ! defined $path || $path eq '';
122 $path =~ s!^/!!;
123
124 if ( $path =~ m{<.*>}s ) {
125 push @{ $self->head }, $path;
126 } elsif ( -e $path ) {
127 if ( $path =~ m/\.(?:js|css)$/ ) {
128 push @{ $self->head }, $path;
129 } else {
130 confess "can't add_head( $path ) it's not js or css";
131 }
132 return -s $path;
133 } else {
134 confess "can't find $path: $!";
135 }
136
137 }
138
139 our $reload_counter = 0;
140
141
142 =head2 page
143
144 $self->page(
145 title => 'page title',
146 head => '<!-- optional head markup -->',
147 body => '<b>Page Body</b>',
148 );
149
150 =cut
151
152 sub page {
153 my $self = shift;
154 my $a = {@_};
155
156 $reload_counter++;
157
158 my $status_line = '';
159 foreach my $part ( @{ $self->status } ) {
160 foreach my $name ( keys %$part ) {
161 my $content = $part->{$name};
162 if ( ref($content) ) {
163 $content = '<code>' . dump($content) . '</code>';
164 my $l = length($content);
165 $content = qq|<span>$l bytes</span>| if $l > $self->dump_max_bytes;
166 } else {
167 $content = qq|<span>$content</span>|;
168 }
169 warn "### part [$name] = ", length( $content ), " bytes" if $self->debug;
170 $status_line .= qq|<span class="frey-popup">$name $content</span>\n|;
171 }
172 }
173
174 my $url = $self->request_url;
175 $url =~ s{\?reload=\d+}{};
176
177 my $body = $a->{body};
178 $body ||= $self->as_markup if $self->can('as_markup');
179 if ( $self->content_type !~ m{html} ) {
180 warn "# return only $self body ", $self->content_type;
181 return $body
182 } elsif ( ! defined $body ) {
183 warn "# no body";
184 $body = '<!-- no body -->';
185 }
186
187 my $warn_colors = {
188 '#' => '#444',
189 '##' => '#888',
190 };
191
192 $status_line
193 .= qq|<span class="frey-popup">warn<span>|
194 . $self->editor_links(
195 join("", map {
196 warn "# $_";
197 my $style = '';
198 $style = $warn_colors->{$1}
199 ? ' style="color:' . $warn_colors->{$1} . '"'
200 : ''
201 if m{^(#+)};
202 qq|<tt$style>$_</tt><br/>|; # XXX <tt> should be <code> but CSS hates me
203 } $self->warnings )
204 )
205 . qq|</span></span>|
206 if $self->warnings;
207
208 my ($exit,$description) = ('exit','stop server');
209 ($exit,$description) = ('restart','restart server')
210 if $ENV{FREY_RESTART}; # tune labels on exit link
211
212 my $right =
213 qq|
214 <span class="right">
215 <a title="reload" href="/reload$url"><code>$url</code></a>
216 <a title="$description" href="/exit$url">$exit</a>
217 </span>
218 |;
219
220 my $info = Frey::SVK->info;
221 my $revision = Frey::SVK->info->{Revision} || '';
222 $revision = $1 if $info->{'Mirrored From'} =~ m{Rev\.\s+(\d+)};
223
224 my $html = join("\n",
225 qq|<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"><html><head>|,
226 $self->_head_html,
227 '<title>' . ( $self->title || $a->{title} || ref($self) ) . '</title>',
228 '<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">',
229 ( $a->{head} || '' ),
230 qq|
231 </head><body>
232 $body
233 <div class="frey-status-line">
234 <a href="/">Frey</a> $Frey::VERSION $revision
235 $status_line
236 $right
237 </div>
238 </body></html>
239 |,
240 );
241
242 warn "## >>> page ",length($html), " bytes\n" if $self->debug;
243
244 return $html;
245 }
246
247 =head2 editor
248
249 Create HTML editor link with optional line and title
250
251 my $html = $self->editor( $class, $line, $title );
252
253 =cut
254
255 sub editor {
256 my ( $self, $class, $line, $title ) = @_;
257 confess "need class" unless $class;
258 $line ||= 1;
259 qq|<a target="editor" href="/editor+$class+$line"| .
260 ( $title ? qq| title="$title"| : '' ) .
261 qq|>$class</a>|;
262 }
263
264 =head2 editor_links
265
266 Create HTML links to editor for perl error message
267
268 my $html = $self->editor_links( $error )
269
270 =cut
271
272 sub editor_links {
273 my ( $self, $error ) = @_;
274
275 $error =~ s{at\s+(\S+)\s+line\s+(\d+)}
276 {at <a target="editor" href="/editor+$1+$2">$1</a> line $2}gsm;
277
278 $error =~ s{(via package ")([\w:]+)(")}
279 {$1<a target="editor" href="/editor+$2+1">$2</a>$3}gsm;
280
281 return $error;
282 }
283
284 sub error {
285 my $self = shift;
286 my $error = join(" ", @_);
287
288 my @backtrace = $self->backtrace;
289 $error .= "\n\t" . join( "\n\t", @backtrace ) if @backtrace;
290
291 warn "ERROR: $error\n";
292 return
293 qq|<pre class="frey-error">|
294 . $self->editor_links( $error ) .
295 qq|</pre>|
296 ;
297 }
298
299 sub add_status {
300 my ( $self, $data ) = @_;
301 push @{ $self->status }, $data;
302 }
303
304 sub DEMOLISH {
305 my ( $self ) = @_;
306 cluck "## DEMOLISH status ", $#{ $self->status } + 1, " elements ", dump( map { keys %$_ } @{ $self->status } );
307 }
308
309 1;

  ViewVC Help
Powered by ViewVC 1.1.26