/[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 644 - (show annotations)
Sun Nov 30 16:21:07 2008 UTC (15 years, 4 months ago) by dpavlin
Original Path: trunk/lib/Frey/Web.pm
File size: 13505 byte(s)
open exit in new target so we can restart Mojo server and just close tab.

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

  ViewVC Help
Powered by ViewVC 1.1.26