/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 532 - (hide 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 dpavlin 100 package Frey::Web;
2     use Moose::Role;
3    
4 dpavlin 465 with 'Frey::Backtrace';
5    
6 dpavlin 388 use Frey::Types;
7    
8 dpavlin 100 use Continuity::Widget::DomNode;
9     use Data::Dump qw/dump/;
10 dpavlin 518 use Carp qw/confess cluck/;
11 dpavlin 161 use File::Slurp;
12 dpavlin 100
13 dpavlin 410 use Frey::Bookmarklet;
14     use Frey::ClassBrowser;
15 dpavlin 505 use Frey::SVK;
16 dpavlin 410
17 dpavlin 156 has 'head' => (
18 dpavlin 121 is => 'rw',
19     isa => 'ArrayRef[Str]',
20 dpavlin 160 default => sub { [ 'static/frey.css' ] },
21 dpavlin 121 );
22    
23 dpavlin 392 has 'request_url' => (
24 dpavlin 388 is => 'rw',
25     isa => 'Uri', coerce => 1,
26     default => '/',
27     );
28    
29 dpavlin 418 has 'title' => (
30     is => 'rw',
31     isa => 'Str',
32     lazy => 1,
33     default => sub {
34     my ($self) = @_;
35     ref($self);
36     },
37     );
38    
39 dpavlin 448 has 'content_type' => (
40     is => 'rw',
41     isa => 'Str',
42     default => 'text/html',
43 dpavlin 476 documentation => 'Content-type header',
44 dpavlin 448 );
45    
46 dpavlin 476 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 dpavlin 206 =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 dpavlin 161 has 'inline_smaller_than' => (
61     is => 'rw',
62     isa => 'Int',
63     default => 10240,
64     );
65    
66 dpavlin 100 sub dom2html {
67 dpavlin 106 # warn "## dom2html ",dump( @_ );
68 dpavlin 100 return Continuity::Widget::DomNode->create( @_ )->to_string;
69     }
70    
71 dpavlin 161 sub _inline_path {
72     my ( $self, $path ) = @_;
73     -s $path < $self->inline_smaller_than;
74     }
75    
76 dpavlin 156 sub _head_html {
77     my $self = shift;
78 dpavlin 121 my $out = '';
79 dpavlin 156 foreach my $path ( @{ $self->head } ) {
80 dpavlin 121 $path =~ s!^/!!;
81 dpavlin 156 if ( $path =~ m/\.js$/ ) {
82 dpavlin 161 $out .= $self->_inline_path( $path ) ?
83 dpavlin 163 qq|<!-- $path --><script type="text/javascript">\n| . read_file($path) . qq|\n</script>| :
84 dpavlin 161 qq|<script type="text/javascript" src="/$path"></script>|;
85 dpavlin 156 } elsif ( $path =~ m/\.css$/ ) {
86 dpavlin 161 $out .= $self->_inline_path( $path ) ?
87 dpavlin 163 qq|<!-- $path --><style type="text/css">\n| . read_file( $path ) . qq|\n</style>| :
88 dpavlin 161 qq|<link type="text/css" rel="stylesheet" href="/$path" media="screen">|;
89 dpavlin 446 } elsif ( $path =~ m{<.+>}s ) {
90 dpavlin 444 $out .= $path;
91 dpavlin 156 } else {
92     confess "don't know how to render $path";
93     }
94 dpavlin 163 $out .= "\n";
95 dpavlin 121 }
96     return $out;
97     }
98 dpavlin 100
99 dpavlin 154 =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 dpavlin 445 $o->add_head( '<!-- html content -->' );
106    
107 dpavlin 154 =cut
108    
109     sub add_head {
110     my ( $self, $path ) = @_;
111     return if ! defined $path || $path eq '';
112     $path =~ s!^/!!;
113    
114 dpavlin 446 if ( $path =~ m{<.*>}s ) {
115 dpavlin 444 push @{ $self->head }, $path;
116     } elsif ( -e $path ) {
117 dpavlin 156 if ( $path =~ m/\.(?:js|css)$/ ) {
118     push @{ $self->head }, $path;
119 dpavlin 154 } else {
120     confess "can't add_head( $path ) it's not js or css";
121     }
122 dpavlin 444 return -s $path;
123 dpavlin 154 } else {
124     confess "can't find $path: $!";
125     }
126    
127     }
128    
129 dpavlin 142 our $reload_counter = 0;
130    
131 dpavlin 183
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 dpavlin 519 our @status;
143     sub status { @status };
144    
145 dpavlin 527 our $icon_html;
146    
147 dpavlin 121 sub page {
148 dpavlin 100 my $self = shift;
149 dpavlin 121 my $a = {@_};
150 dpavlin 100
151 dpavlin 519 warn "## page ",dump($a);
152    
153 dpavlin 142 $reload_counter++;
154    
155 dpavlin 388 my $status_line = '';
156 dpavlin 519
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 dpavlin 388 foreach my $name ( keys %$part ) {
162 dpavlin 392 my $content = $part->{$name};
163     if ( ref($content) ) {
164 dpavlin 397 $content = '<code>' . dump($content) . '</code>';
165     my $l = length($content);
166 dpavlin 476 $content = qq|<span>$l bytes</span>| if $l > $self->dump_max_bytes;
167 dpavlin 392 } else {
168     $content = qq|<span>$content</span>|;
169     }
170     warn "### part [$name] = ", length( $content ), " bytes" if $self->debug;
171 dpavlin 397 $status_line .= qq|<span class="frey-popup">$name $content</span>\n|;
172 dpavlin 388 }
173     }
174    
175 dpavlin 439 my $url = $self->request_url;
176     $url =~ s{\?reload=\d+}{};
177    
178 dpavlin 460 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 dpavlin 448
188 dpavlin 532 $status_line .= $self->warnings_html;
189 dpavlin 482
190 dpavlin 477 my ($exit,$description) = ('exit','stop server');
191     ($exit,$description) = ('restart','restart server')
192     if $ENV{FREY_RESTART}; # tune labels on exit link
193    
194 dpavlin 473 my $right =
195     qq|
196     <span class="right">
197 dpavlin 519 <a title="reload $url" href="/reload$url">reload</a>
198 dpavlin 477 <a title="$description" href="/exit$url">$exit</a>
199 dpavlin 473 </span>
200     |;
201    
202 dpavlin 516 my $info = Frey::SVK->info;
203 dpavlin 505 my $revision = Frey::SVK->info->{Revision} || '';
204 dpavlin 516 $revision = $1 if $info->{'Mirrored From'} =~ m{Rev\.\s+(\d+)};
205 dpavlin 505
206 dpavlin 527 $self->add_icon unless $icon_html;
207 dpavlin 524
208 dpavlin 388 my $html = join("\n",
209     qq|<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"><html><head>|,
210     $self->_head_html,
211 dpavlin 418 '<title>' . ( $self->title || $a->{title} || ref($self) ) . '</title>',
212 dpavlin 388 '<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">',
213 dpavlin 527 ( $icon_html || '<!-- no icon -->' ),
214 dpavlin 388 ( $a->{head} || '' ),
215     qq|
216 dpavlin 448 </head><body>
217     $body
218 dpavlin 388 <div class="frey-status-line">
219 dpavlin 505 <a href="/">Frey</a> $Frey::VERSION $revision
220 dpavlin 388 $status_line
221 dpavlin 473 $right
222 dpavlin 210 </div>
223     </body></html>
224 dpavlin 388 |,
225     );
226 dpavlin 100
227 dpavlin 121 warn "## >>> page ",length($html), " bytes\n" if $self->debug;
228 dpavlin 100
229 dpavlin 121 return $html;
230 dpavlin 100 }
231    
232 dpavlin 480 =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 dpavlin 519 if ( ! defined $title ) {
244     $title = "edit $class";
245     $title .= " line $line" if $line;
246     }
247     $line ||= 1;
248 dpavlin 480 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 dpavlin 468 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 dpavlin 350 sub error {
274 dpavlin 397 my $self = shift;
275     my $error = join(" ", @_);
276 dpavlin 460
277 dpavlin 465 my @backtrace = $self->backtrace;
278     $error .= "\n\t" . join( "\n\t", @backtrace ) if @backtrace;
279 dpavlin 460
280     warn "ERROR: $error\n";
281 dpavlin 468 return
282     qq|<pre class="frey-error">|
283     . $self->editor_links( $error ) .
284     qq|</pre>|
285     ;
286 dpavlin 350 }
287    
288 dpavlin 507 sub add_status {
289     my ( $self, $data ) = @_;
290 dpavlin 519 push @status, $data;
291 dpavlin 507 }
292    
293 dpavlin 519 sub clean_status {
294     @status = ();
295 dpavlin 527 $icon_html = '';
296 dpavlin 519 }
297    
298     sub status_parts {
299     warn "## status parts ", dump( map { keys %$_ } @status );
300     }
301    
302 dpavlin 518 sub DEMOLISH {
303     my ( $self ) = @_;
304 dpavlin 529 warn "## $self DEMOLISH status ", $#status + 1, " elements ", dump( map { keys %$_ } @status ) if @status;
305 dpavlin 518 }
306    
307 dpavlin 527 =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 dpavlin 529 sub icon_path {
315     my ($self,$class,$variant) = @_;
316     my $icon = $class;
317 dpavlin 524 $icon =~ s{::}{/}g;
318 dpavlin 529 $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 dpavlin 524
329 dpavlin 529 sub add_icon {
330     my ($self,$variant) = @_;
331 dpavlin 524
332 dpavlin 529 my $class = ref($self);
333     $class = $self->class if $self->can('class');
334     my $icon_path = $self->icon_path( $class, $variant ) || return;
335 dpavlin 524
336 dpavlin 529 $icon_html .= qq|<link rel="icon" type="image/png" href="/$icon_path">|;
337     warn "# using icon $icon_path";
338    
339 dpavlin 527 =for later
340    
341 dpavlin 529 # 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 dpavlin 524
350 dpavlin 527 =cut
351    
352 dpavlin 524 }
353    
354 dpavlin 532 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 dpavlin 100 1;

  ViewVC Help
Powered by ViewVC 1.1.26