/[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 532 - (show annotations)
Wed Nov 26 07:57:12 2008 UTC (15 years, 4 months ago) by dpavlin
Original Path: trunk/lib/Frey/Web.pm
File size: 9152 byte(s)
refactor Frey::Boostrap from Frey::Server to have correct warn handling

- we now use File::Tee to capture STDERR to file and display that
  (with filtering) for display
- added FREY_NO_LOG enviroment variable to disable logging (for perl -c)
- move all warnings handling into Frey::Web->warnings_html
- make Frey->debug Int (this touched a bunch of tests)
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 'request_url' => (
24 is => 'rw',
25 isa => 'Uri', coerce => 1,
26 default => '/',
27 );
28
29 has 'title' => (
30 is => 'rw',
31 isa => 'Str',
32 lazy => 1,
33 default => sub {
34 my ($self) = @_;
35 ref($self);
36 },
37 );
38
39 has 'content_type' => (
40 is => 'rw',
41 isa => 'Str',
42 default => 'text/html',
43 documentation => 'Content-type header',
44 );
45
46 has 'dump_max_bytes' => (
47 is => 'rw',
48 isa => 'Int',
49 default => 4096,
50 documentation => 'Maximum dump size sent to browser before truncation',
51 );
52
53 =head2 inline_smaller_than
54
55 Inline JavaScript and CSS smaller than this size into page reducing
56 round-trips to server.
57
58 =cut
59
60 has 'inline_smaller_than' => (
61 is => 'rw',
62 isa => 'Int',
63 default => 10240,
64 );
65
66 sub dom2html {
67 # warn "## dom2html ",dump( @_ );
68 return Continuity::Widget::DomNode->create( @_ )->to_string;
69 }
70
71 sub _inline_path {
72 my ( $self, $path ) = @_;
73 -s $path < $self->inline_smaller_than;
74 }
75
76 sub _head_html {
77 my $self = shift;
78 my $out = '';
79 foreach my $path ( @{ $self->head } ) {
80 $path =~ s!^/!!;
81 if ( $path =~ m/\.js$/ ) {
82 $out .= $self->_inline_path( $path ) ?
83 qq|<!-- $path --><script type="text/javascript">\n| . read_file($path) . qq|\n</script>| :
84 qq|<script type="text/javascript" src="/$path"></script>|;
85 } elsif ( $path =~ m/\.css$/ ) {
86 $out .= $self->_inline_path( $path ) ?
87 qq|<!-- $path --><style type="text/css">\n| . read_file( $path ) . qq|\n</style>| :
88 qq|<link type="text/css" rel="stylesheet" href="/$path" media="screen">|;
89 } elsif ( $path =~ m{<.+>}s ) {
90 $out .= $path;
91 } else {
92 confess "don't know how to render $path";
93 }
94 $out .= "\n";
95 }
96 return $out;
97 }
98
99 =head2 add_head
100
101 $o->add_head( 'path/to/external.js' );
102
103 my $size = $o->add_head( 'path/to/external.css' );
104
105 $o->add_head( '<!-- html content -->' );
106
107 =cut
108
109 sub add_head {
110 my ( $self, $path ) = @_;
111 return if ! defined $path || $path eq '';
112 $path =~ s!^/!!;
113
114 if ( $path =~ m{<.*>}s ) {
115 push @{ $self->head }, $path;
116 } elsif ( -e $path ) {
117 if ( $path =~ m/\.(?:js|css)$/ ) {
118 push @{ $self->head }, $path;
119 } else {
120 confess "can't add_head( $path ) it's not js or css";
121 }
122 return -s $path;
123 } else {
124 confess "can't find $path: $!";
125 }
126
127 }
128
129 our $reload_counter = 0;
130
131
132 =head2 page
133
134 $self->page(
135 title => 'page title',
136 head => '<!-- optional head markup -->',
137 body => '<b>Page Body</b>',
138 );
139
140 =cut
141
142 our @status;
143 sub status { @status };
144
145 our $icon_html;
146
147 sub page {
148 my $self = shift;
149 my $a = {@_};
150
151 warn "## page ",dump($a);
152
153 $reload_counter++;
154
155 my $status_line = '';
156
157 unshift @status, { 'ClassBrowser' => Frey::ClassBrowser->new( usage_on_top => 0 )->as_markup };
158 unshift @status, { 'Bookmarklets' => Frey::Bookmarklet->new->as_markup };
159
160 foreach my $part ( @status ) {
161 foreach my $name ( keys %$part ) {
162 my $content = $part->{$name};
163 if ( ref($content) ) {
164 $content = '<code>' . dump($content) . '</code>';
165 my $l = length($content);
166 $content = qq|<span>$l bytes</span>| if $l > $self->dump_max_bytes;
167 } else {
168 $content = qq|<span>$content</span>|;
169 }
170 warn "### part [$name] = ", length( $content ), " bytes" if $self->debug;
171 $status_line .= qq|<span class="frey-popup">$name $content</span>\n|;
172 }
173 }
174
175 my $url = $self->request_url;
176 $url =~ s{\?reload=\d+}{};
177
178 my $body = $a->{body};
179 $body ||= $self->as_markup if $self->can('as_markup');
180 if ( $self->content_type !~ m{html} ) {
181 warn "# return only $self body ", $self->content_type;
182 return $body
183 } elsif ( ! defined $body ) {
184 warn "# no body";
185 $body = '<!-- no body -->';
186 }
187
188 $status_line .= $self->warnings_html;
189
190 my ($exit,$description) = ('exit','stop server');
191 ($exit,$description) = ('restart','restart server')
192 if $ENV{FREY_RESTART}; # tune labels on exit link
193
194 my $right =
195 qq|
196 <span class="right">
197 <a title="reload $url" href="/reload$url">reload</a>
198 <a title="$description" href="/exit$url">$exit</a>
199 </span>
200 |;
201
202 my $info = Frey::SVK->info;
203 my $revision = Frey::SVK->info->{Revision} || '';
204 $revision = $1 if $info->{'Mirrored From'} =~ m{Rev\.\s+(\d+)};
205
206 $self->add_icon unless $icon_html;
207
208 my $html = join("\n",
209 qq|<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"><html><head>|,
210 $self->_head_html,
211 '<title>' . ( $self->title || $a->{title} || ref($self) ) . '</title>',
212 '<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">',
213 ( $icon_html || '<!-- no icon -->' ),
214 ( $a->{head} || '' ),
215 qq|
216 </head><body>
217 $body
218 <div class="frey-status-line">
219 <a href="/">Frey</a> $Frey::VERSION $revision
220 $status_line
221 $right
222 </div>
223 </body></html>
224 |,
225 );
226
227 warn "## >>> page ",length($html), " bytes\n" if $self->debug;
228
229 return $html;
230 }
231
232 =head2 editor
233
234 Create HTML editor link with optional line and title
235
236 my $html = $self->editor( $class, $line, $title );
237
238 =cut
239
240 sub editor {
241 my ( $self, $class, $line, $title ) = @_;
242 confess "need class" unless $class;
243 if ( ! defined $title ) {
244 $title = "edit $class";
245 $title .= " line $line" if $line;
246 }
247 $line ||= 1;
248 qq|<a target="editor" href="/editor+$class+$line"| .
249 ( $title ? qq| title="$title"| : '' ) .
250 qq|>$class</a>|;
251 }
252
253 =head2 editor_links
254
255 Create HTML links to editor for perl error message
256
257 my $html = $self->editor_links( $error )
258
259 =cut
260
261 sub editor_links {
262 my ( $self, $error ) = @_;
263
264 $error =~ s{at\s+(\S+)\s+line\s+(\d+)}
265 {at <a target="editor" href="/editor+$1+$2">$1</a> line $2}gsm;
266
267 $error =~ s{(via package ")([\w:]+)(")}
268 {$1<a target="editor" href="/editor+$2+1">$2</a>$3}gsm;
269
270 return $error;
271 }
272
273 sub error {
274 my $self = shift;
275 my $error = join(" ", @_);
276
277 my @backtrace = $self->backtrace;
278 $error .= "\n\t" . join( "\n\t", @backtrace ) if @backtrace;
279
280 warn "ERROR: $error\n";
281 return
282 qq|<pre class="frey-error">|
283 . $self->editor_links( $error ) .
284 qq|</pre>|
285 ;
286 }
287
288 sub add_status {
289 my ( $self, $data ) = @_;
290 push @status, $data;
291 }
292
293 sub clean_status {
294 @status = ();
295 $icon_html = '';
296 }
297
298 sub status_parts {
299 warn "## status parts ", dump( map { keys %$_ } @status );
300 }
301
302 sub DEMOLISH {
303 my ( $self ) = @_;
304 warn "## $self DEMOLISH status ", $#status + 1, " elements ", dump( map { keys %$_ } @status ) if @status;
305 }
306
307 =head2 add_icon
308
309 Frey::Foo->add_icon; # /static/icons/Frey/Foo.png
310 Frey::Foo->add_icon('warning'); # /static/icons/Frey/Foo/warning.png
311
312 =cut
313
314 sub icon_path {
315 my ($self,$class,$variant) = @_;
316 my $icon = $class;
317 $icon =~ s{::}{/}g;
318 $icon .= "/$variant" if $variant;
319 my $path = 'static/icons/' . $icon . '.png';
320 if ( -e $path ) {
321 warn "# $class from $self icon_path $path";
322 return $path;
323 } else {
324 warn "TODO: add $path icon for $class";
325 return undef;
326 }
327 }
328
329 sub add_icon {
330 my ($self,$variant) = @_;
331
332 my $class = ref($self);
333 $class = $self->class if $self->can('class');
334 my $icon_path = $self->icon_path( $class, $variant ) || return;
335
336 $icon_html .= qq|<link rel="icon" type="image/png" href="/$icon_path">|;
337 warn "# using icon $icon_path";
338
339 =for later
340
341 # FIXME http://en.wikipedia.org/wiki/Favicon suggest just rel="icon" but that doesn't seem to work!
342 my $ico_path = $icon_path;
343 $ico_path =~ s{png$}{ico};
344 if ( ! -e $ico_path ) {
345 system "convert $icon_path $ico_path";
346 warn "# convert $icon_path $ico_path : $@";
347 }
348 $icon_html .= qq|<link rel="shortcut icon" type="image/x-icon" href="/$ico_path">| if -e $ico_path;
349
350 =cut
351
352 }
353
354 my $warn_colors = {
355 '#' => '#444',
356 '##' => '#888',
357 };
358
359 my $multiline_markers = {
360 '(' => '\)',
361 '{' => '}',
362 '[' => '\]',
363 '"' => '"',
364 };
365
366 my $multiline_re = '[\\' . join('\\', keys %$multiline_markers ) . ']';
367 warn "## multiline markers ", dump( $multiline_markers ), " -> $multiline_re";
368
369 sub log_path {
370 $Frey::Bootstrap::log_path || warn "no log_path?";
371 }
372
373 sub warnings_html {
374 my ($self,$level) = shift;
375 $level ||= $self->debug;
376 my $path = $self->log_path;
377
378 my $warnings;
379 my $line = 0;
380 my $multiline_end;
381
382 open(my $log, '<', $path) || die "can't open $path: $!";
383 while(<$log>) {
384 chomp;
385 $line++;
386
387 if ( $multiline_end ) {
388 undef $multiline_end if m{^$multiline_end};
389 next;
390 }
391
392 my $style = '';
393
394 if ( m{^(#*)\s+} ) {
395 my $l = $1 ? length($1) : 0;
396 $multiline_end = $multiline_markers->{$1} if m{($multiline_re)$};
397 next if $l > $level;
398 warn "## multiline_end: $multiline_end $l > $level for '$_'" if $multiline_end;
399 undef $multiline_end;
400
401 $style = $warn_colors->{$1}
402 ? ' style="color:' . $warn_colors->{$1} . '"'
403 : '';
404
405 $warnings .= qq|<tt$style>$_</tt> <small> <a target="editor" href="/editor+$path+$line">+$line</a> </small> <br/>|;
406 # FIXME <tt> should be <code> but CSS hates me
407 }
408 }
409 close($log) || die "can't close $path: $!";
410
411 return
412 qq|<span class="frey-popup"><a target="editor" href="/editor+$path+$line" title="open $path level $level">warn</a><span>|
413 . $self->editor_links( $warnings )
414 . qq|</span></span>|
415 ;
416 }
417
418 1;

  ViewVC Help
Powered by ViewVC 1.1.26