/[Frey]/trunk/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 /trunk/lib/Frey/Web.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.26