/[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 546 - (show annotations)
Wed Nov 26 20:48:07 2008 UTC (15 years, 4 months ago) by dpavlin
Original Path: trunk/lib/Frey/Web.pm
File size: 11186 byte(s)
better html detection, cleanup code and move around in class
1 package Frey::Web;
2 use Moose::Role;
3
4 use Frey::Types;
5
6 use Continuity::Widget::DomNode;
7 use Data::Dump qw/dump/;
8 use Carp qw/confess cluck/;
9 use File::Slurp;
10
11 use Frey::Bookmarklet;
12 use Frey::ClassBrowser;
13 use Frey::INC;
14
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 has 'inline_smaller_than' => (
54 is => 'rw',
55 isa => 'Int',
56 default => 10240,
57 documentation => 'inline JavaScript and CSS to reduce round-trips',
58 );
59
60 has 'html_dump_width' => (
61 documentation => 'crop longer lines in dumps',
62 is => 'rw',
63 isa => 'Int',
64 # required => 1, # FIXME we can't have required fields with defaults because Frey::Action isn't smart enough and asks for them
65 default => 128,
66 );
67
68 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
69 my $escape_re = join '|' => keys %escape;
70
71 sub html_escape {
72 my ( $self, $html ) = @_;
73 $html =~ s/($escape_re)/$escape{$1}/g;
74 return $html;
75 }
76
77 sub html_dump {
78 my ( $self, $dump ) = @_;
79 $dump = dump( $dump ) if ref($dump);
80 my $width = $self->html_dump_width;
81 $dump =~ s{(\n[^\n]{$width})([^\n]+?)([^\n]{5})}{\n$1...$3}gs;
82 $dump = $self->html_escape( $dump );
83 $dump =~ s{\Q...\E}{&hellip;}gs;
84 return "<code>$dump</code>";
85 }
86
87 sub popup { my $self = shift; $self->popup_dropdown('popup', @_); }
88 sub dropdown { my $self = shift; $self->popup_dropdown('dropdown', @_); }
89
90 our $re_html = qr{<(?:!--.+?--|(\w+).+?/\1)>}s; # relaxed html check for one semi-valid tag
91
92 sub popup_dropdown {
93 my ( $self, $type, $name, $content, $full ) = @_;
94
95 $content = $self->html_dump($content) if ref $content;
96
97 $content = qq|<span>$content</span>| unless $content =~ m{^\s*<(span|a|code).+?/\1>\s*};
98
99 warn "## $type [$name] = ", length( $content ), " bytes" if $self->debug;
100
101 if ( $name =~ m{::} && $name !~ $re_html ) {
102 return qq|<a class="frey-$type" target="$name" href="/$name">$name $content</a>\n|;
103 } else {
104 return qq|<span class="frey-$type">$name $content</span>\n|;
105 }
106 }
107
108 sub dom2html {
109 # warn "## dom2html ",dump( @_ );
110 return Continuity::Widget::DomNode->create( @_ )->to_string;
111 }
112
113 sub _inline_path {
114 my ( $self, $path ) = @_;
115 -s $path < $self->inline_smaller_than;
116 }
117
118 sub _head_html {
119 my $self = shift;
120 my $out = '';
121 foreach my $path ( @{ $self->head } ) {
122 $path =~ s!^/!!;
123 if ( $path =~ m/\.js$/ ) {
124 $out .= $self->_inline_path( $path ) ?
125 qq|<!-- $path --><script type="text/javascript">\n| . read_file($path) . qq|\n</script>| :
126 qq|<script type="text/javascript" src="/$path"></script>|;
127 } elsif ( $path =~ m/\.css$/ ) {
128 $out .= $self->_inline_path( $path ) ?
129 qq|<!-- $path --><style type="text/css">\n| . read_file( $path ) . qq|\n</style>| :
130 qq|<link type="text/css" rel="stylesheet" href="/$path" media="screen">|;
131 } elsif ( $path =~ m{<.+>}s ) {
132 $out .= $path;
133 } else {
134 confess "don't know how to render $path";
135 }
136 $out .= "\n";
137 }
138 return $out;
139 }
140
141 =head2 add_head
142
143 $o->add_head( 'path/to/external.js' );
144
145 my $size = $o->add_head( 'path/to/external.css' );
146
147 $o->add_head( '<!-- html content -->' );
148
149 =cut
150
151 sub add_head {
152 my ( $self, $path ) = @_;
153 return if ! defined $path || $path eq '';
154 $path =~ s!^/!!;
155
156 if ( $path =~ $re_html ) {
157 push @{ $self->head }, $path;
158 } elsif ( -e $path ) {
159 if ( $path =~ m/\.(?:js|css)$/ ) {
160 push @{ $self->head }, $path;
161 } else {
162 confess "can't add_head( $path ) it's not js or css";
163 }
164 return -s $path;
165 } else {
166 confess "can't find $path: $!";
167 }
168
169 }
170
171 our $reload_counter = 0;
172
173
174 =head2 page
175
176 $self->page(
177 title => 'page title',
178 head => '<!-- optional head markup -->',
179 body => '<b>Page Body</b>',
180 );
181
182 =cut
183
184 our @status;
185 sub status { @status };
186
187 our $icon_html;
188
189 sub page {
190 my $self = shift;
191 my $a = {@_};
192
193 warn "## page ",dump($a);
194
195 $reload_counter++;
196
197 my $status_line = '';
198
199 unshift @status, { 'ClassBrowser' => Frey::ClassBrowser->new( usage_on_top => 0 )->as_markup };
200 # unshift @status, { 'Bookmarklets' => Frey::Bookmarklet->new->as_markup };
201 unshift @status, { 'INC' => Frey::INC->new->as_markup };
202
203 foreach my $part ( @status ) {
204 foreach my $name ( keys %$part ) {
205 $status_line .= $self->popup( $name, $part->{$name} );
206 }
207 }
208
209 my $url = $self->request_url;
210 $url =~ s{\?reload=\d+}{};
211
212 my $body = $a->{body};
213 $body ||= $self->as_markup if $self->can('as_markup');
214 if ( $self->content_type !~ m{html} ) {
215 warn "# return only $self body ", $self->content_type;
216 return $body
217 } elsif ( ! defined $body ) {
218 warn "# no body";
219 $body = '<!-- no body -->';
220 }
221
222 $status_line .= $self->warnings_html;
223
224 my ($exit,$description) = ('exit','stop server');
225 ($exit,$description) = ('restart','restart server')
226 if $ENV{FREY_RESTART}; # tune labels on exit link
227
228 my $right =
229 qq|
230 <span class="right">
231 <a title="reload $url" href="/reload$url">reload</a>
232 <a title="$description" href="/exit$url">$exit</a>
233 </span>
234 |;
235
236 my $info = Frey::SVK->info;
237 my $revision = Frey::SVK->info->{Revision} || '';
238 $revision = $1 if $info->{'Mirrored From'} =~ m{Rev\.\s+(\d+)};
239
240 $self->add_icon unless $icon_html;
241
242 my $html = join("\n",
243 qq|<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"><html><head>|,
244 $self->_head_html,
245 '<title>' . ( $self->title || $a->{title} || ref($self) ) . '</title>',
246 '<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">',
247 ( $icon_html || '<!-- no icon -->' ),
248 ( $a->{head} || '' ),
249 qq|
250 </head><body>
251 $body
252 <div class="frey-status-line">
253 <a href="/">Frey</a> $Frey::VERSION $revision
254 $status_line
255 $right
256 </div>
257 </body></html>
258 |,
259 );
260
261 warn "## >>> page ",length($html), " bytes\n" if $self->debug;
262
263 return $html;
264 }
265
266 =head2 editor
267
268 Create HTML editor link with optional line and title
269
270 my $html = $self->editor( $class, $line, $title );
271
272 =cut
273
274 sub editor {
275 my ( $self, $class, $line, $title ) = @_;
276 confess "need class" unless $class;
277 if ( ! defined $title ) {
278 $title = "edit $class";
279 $title .= " line $line" if $line;
280 }
281 $line ||= 1;
282 qq|<a target="editor" href="/editor+$class+$line"| .
283 ( $title ? qq| title="$title"| : '' ) .
284 qq|>$class</a>|;
285 }
286
287 =head2 editor_links
288
289 Create HTML links to editor for perl error message
290
291 my $html = $self->editor_links( $error )
292
293 =cut
294
295 sub editor_links {
296 my ( $self, $error ) = @_;
297
298 $error =~ s{at\s+(\S+)\s+line\s+(\d+)}
299 {at <a target="editor" href="/editor+$1+$2">$1</a> line $2}gsm;
300
301 $error =~ s{(via package ")([\w:]+)(")}
302 {$1<a target="editor" href="/editor+$2+1">$2</a>$3}gsm;
303
304 return $error;
305 }
306
307 sub error {
308 my $self = shift;
309 my $error = join(" ", @_);
310
311 my @backtrace = $self->backtrace;
312 $error .= "\n\t" . join( "\n\t", @backtrace ) if @backtrace;
313
314 warn "ERROR: $error\n";
315 return
316 qq|<pre class="frey-error">|
317 . $self->editor_links( $error ) .
318 qq|</pre>|
319 ;
320 }
321
322 sub add_status {
323 my ( $self, $data ) = @_;
324 push @status, $data;
325 }
326
327 sub clean_status {
328 @status = ();
329 $icon_html = '';
330 }
331
332 sub status_parts {
333 warn "## status parts ", dump( map { keys %$_ } @status );
334 }
335
336 sub DEMOLISH {
337 my ( $self ) = @_;
338 warn "## $self DEMOLISH status ", $#status + 1, " elements ", dump( map { keys %$_ } @status ) if @status;
339 }
340
341 =head2 add_icon
342
343 Frey::Foo->add_icon; # /static/icons/Frey/Foo.png
344 Frey::Foo->add_icon('warning'); # /static/icons/Frey/Foo/warning.png
345
346 =cut
347
348 sub icon_path {
349 my ($self,$class,$variant) = @_;
350 my $icon = $class;
351 $icon =~ s{::}{/}g;
352 $icon .= "/$variant" if $variant;
353 my $path = 'static/icons/' . $icon . '.png';
354 if ( -e $path ) {
355 warn "# $class from $self icon_path $path";
356 return $path;
357 } else {
358 warn "TODO: add $path icon for $class";
359 return undef;
360 }
361 }
362
363 sub add_icon {
364 my ($self,$variant) = @_;
365
366 my $class = ref($self);
367 $class = $self->class if $self->can('class');
368 my $icon_path = $self->icon_path( $class, $variant ) || return;
369
370 $icon_html .= qq|<link rel="icon" type="image/png" href="/$icon_path">|;
371 warn "# using icon $icon_path";
372
373 =for later
374
375 # FIXME http://en.wikipedia.org/wiki/Favicon suggest just rel="icon" but that doesn't seem to work!
376 my $ico_path = $icon_path;
377 $ico_path =~ s{png$}{ico};
378 if ( ! -e $ico_path ) {
379 system "convert $icon_path $ico_path";
380 warn "# convert $icon_path $ico_path : $@";
381 }
382 $icon_html .= qq|<link rel="shortcut icon" type="image/x-icon" href="/$ico_path">| if -e $ico_path;
383
384 =cut
385
386 }
387
388 my $warn_colors = {
389 '#' => '#444',
390 '##' => '#888',
391 };
392
393 my $multiline_markers = {
394 '(' => ')',
395 '{' => '}',
396 '[' => ']',
397 '"' => '"',
398 };
399
400 my $multiline_re = '[\\' . join('\\', keys %$multiline_markers ) . ']';
401 warn "## multiline markers ", dump( $multiline_markers ), " -> $multiline_re";
402
403 sub log_path {
404 $Frey::Bootstrap::log_path || warn "no log_path?";
405 }
406
407 sub warnings_html {
408 my ($self,$level) = shift;
409 $level ||= $self->debug,
410 my $path = $self->log_path;
411
412 my $warnings;
413 my $line = 0;
414 my $multiline_end;
415
416 open(my $log, '<', $path) || die "can't open $path: $!";
417 while(<$log>) {
418 chomp;
419 $line++;
420
421 my $style = '';
422
423 if ( $multiline_end ) {
424 if ( m{^\Q$multiline_end\E} || m{^\s.+\Q$multiline_end\E;$} ) {
425 # warn "## $line end of $multiline_end in '$_'\n";
426 undef $multiline_end;
427 } else {
428 # warn "## $line skipped\n";
429 }
430 } elsif ( m{^(#*)\s+} ) {
431 my $l = $1 ? length($1) : 0;
432 if ( $l > $level ) {
433 undef $multiline_end;
434 $multiline_end = $multiline_markers->{$1} if m{($multiline_re)$};
435 # warn "## $line start $1 .. $multiline_end level $l > $level for '$_'\n" if $multiline_end;
436 next;
437 }
438
439 $style = $warn_colors->{$1}
440 ? ' style="color:' . $warn_colors->{$1} . '"'
441 : '';
442
443 my $msg = $self->html_escape( $_ );
444 my $spacer = ' ';
445 if ( length($msg) > $self->html_dump_width ) {
446 $msg = substr( $msg, 0, $self->html_dump_width );
447 $spacer = '&hellip;'
448 }
449 $msg =~ s{^\s}{&nbsp;}g;
450 $warnings .= qq|<tt$style>$msg</tt>$spacer<small><a target="editor" href="/editor+$path+$line">+$line</a></small><br/>|;
451 # FIXME <tt> should be <code> but CSS hates me
452 }
453 }
454 close($log) || die "can't close $path: $!";
455
456 return
457 qq|<span class="frey-popup"><a target="editor" href="/editor+$path+$line" title="open $path level $level">warn</a><span>|
458 . $self->editor_links( $warnings )
459 . qq|</span></span>|
460 ;
461 }
462
463
464 =head2 backtrace
465
466 Show backtrace with links to editor
467
468 my @backtrace = $self->backtrace;
469
470 =cut
471
472 sub backtrace {
473 my ($self) = @_;
474
475 my @backtrace;
476 foreach ( 0 .. 5 ) {
477 my (
478 $package,$path,$line
479 # subroutine hasargs
480 # wantarray evaltext is_require
481 # hints bitmask hinthash
482 ) = caller($_) or last;
483
484 push @backtrace,
485 qq|via $package from $path <a target="editor" href="/editor+$path+$line">$path</a>|;
486 }
487 warn "# backtrace: ", dump( @backtrace ) if @backtrace;
488 return @backtrace;
489 }
490
491 1;

  ViewVC Help
Powered by ViewVC 1.1.26