/[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 507 - (show annotations)
Tue Nov 25 00:26:15 2008 UTC (15 years, 4 months ago) by dpavlin
Original Path: trunk/lib/Frey/Web.pm
File size: 6552 byte(s)
new add_status to add data to status line (not working fully yet)
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/;
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 'status' => (
24 is => 'rw',
25 isa => 'ArrayRef[HashRef[Str]]',
26 lazy => 1,
27 default => sub { [
28 { 'ClassBrowser' => Frey::ClassBrowser->new( usage_on_top => 0 )->as_markup },
29 { 'Bookmarklets' => Frey::Bookmarklet->new->as_markup },
30 ] },
31 );
32
33 has 'request_url' => (
34 is => 'rw',
35 isa => 'Uri', coerce => 1,
36 default => '/',
37 );
38
39 has 'title' => (
40 is => 'rw',
41 isa => 'Str',
42 lazy => 1,
43 default => sub {
44 my ($self) = @_;
45 ref($self);
46 },
47 );
48
49 has 'content_type' => (
50 is => 'rw',
51 isa => 'Str',
52 default => 'text/html',
53 documentation => 'Content-type header',
54 );
55
56 has 'dump_max_bytes' => (
57 is => 'rw',
58 isa => 'Int',
59 default => 4096,
60 documentation => 'Maximum dump size sent to browser before truncation',
61 );
62
63 =head2 inline_smaller_than
64
65 Inline JavaScript and CSS smaller than this size into page reducing
66 round-trips to server.
67
68 =cut
69
70 has 'inline_smaller_than' => (
71 is => 'rw',
72 isa => 'Int',
73 default => 10240,
74 );
75
76 sub dom2html {
77 # warn "## dom2html ",dump( @_ );
78 return Continuity::Widget::DomNode->create( @_ )->to_string;
79 }
80
81 sub _inline_path {
82 my ( $self, $path ) = @_;
83 -s $path < $self->inline_smaller_than;
84 }
85
86 sub _head_html {
87 my $self = shift;
88 my $out = '';
89 foreach my $path ( @{ $self->head } ) {
90 $path =~ s!^/!!;
91 if ( $path =~ m/\.js$/ ) {
92 $out .= $self->_inline_path( $path ) ?
93 qq|<!-- $path --><script type="text/javascript">\n| . read_file($path) . qq|\n</script>| :
94 qq|<script type="text/javascript" src="/$path"></script>|;
95 } elsif ( $path =~ m/\.css$/ ) {
96 $out .= $self->_inline_path( $path ) ?
97 qq|<!-- $path --><style type="text/css">\n| . read_file( $path ) . qq|\n</style>| :
98 qq|<link type="text/css" rel="stylesheet" href="/$path" media="screen">|;
99 } elsif ( $path =~ m{<.+>}s ) {
100 $out .= $path;
101 } else {
102 confess "don't know how to render $path";
103 }
104 $out .= "\n";
105 }
106 return $out;
107 }
108
109 =head2 add_head
110
111 $o->add_head( 'path/to/external.js' );
112
113 my $size = $o->add_head( 'path/to/external.css' );
114
115 $o->add_head( '<!-- html content -->' );
116
117 =cut
118
119 sub add_head {
120 my ( $self, $path ) = @_;
121 return if ! defined $path || $path eq '';
122 $path =~ s!^/!!;
123
124 if ( $path =~ m{<.*>}s ) {
125 push @{ $self->head }, $path;
126 } elsif ( -e $path ) {
127 if ( $path =~ m/\.(?:js|css)$/ ) {
128 push @{ $self->head }, $path;
129 } else {
130 confess "can't add_head( $path ) it's not js or css";
131 }
132 return -s $path;
133 } else {
134 confess "can't find $path: $!";
135 }
136
137 }
138
139 our $reload_counter = 0;
140
141
142 =head2 page
143
144 $self->page(
145 title => 'page title',
146 head => '<!-- optional head markup -->',
147 body => '<b>Page Body</b>',
148 );
149
150 =cut
151
152 sub page {
153 my $self = shift;
154 my $a = {@_};
155
156 $reload_counter++;
157
158 my $status_line = '';
159 foreach my $part ( @{ $self->status } ) {
160 if ( ref($part) ne 'HASH' ) {
161 warn "part not hash ",dump( $part ) ;
162 #$self->status( $part );
163 next;
164 }
165 foreach my $name ( keys %$part ) {
166 my $content = $part->{$name};
167 if ( ref($content) ) {
168 $content = '<code>' . dump($content) . '</code>';
169 my $l = length($content);
170 $content = qq|<span>$l bytes</span>| if $l > $self->dump_max_bytes;
171 } else {
172 $content = qq|<span>$content</span>|;
173 }
174 warn "### part [$name] = ", length( $content ), " bytes" if $self->debug;
175 $status_line .= qq|<span class="frey-popup">$name $content</span>\n|;
176 }
177 }
178
179 my $url = $self->request_url;
180 $url =~ s{\?reload=\d+}{};
181
182 my $body = $a->{body};
183 $body ||= $self->as_markup if $self->can('as_markup');
184 if ( $self->content_type !~ m{html} ) {
185 warn "# return only $self body ", $self->content_type;
186 return $body
187 } elsif ( ! defined $body ) {
188 warn "# no body";
189 $body = '<!-- no body -->';
190 }
191
192 my $warn_colors = {
193 '#' => '#444',
194 '##' => '#888',
195 };
196
197 $status_line
198 .= qq|<span class="frey-popup">warn<span>|
199 . $self->editor_links(
200 join("", map {
201 warn "# $_";
202 my $style = '';
203 $style = $warn_colors->{$1}
204 ? ' style="color:' . $warn_colors->{$1} . '"'
205 : ''
206 if m{^(#+)};
207 qq|<tt$style>$_</tt><br/>|; # XXX <tt> should be <code> but CSS hates me
208 } $self->warnings )
209 )
210 . qq|</span></span>|
211 if $self->warnings;
212
213 my ($exit,$description) = ('exit','stop server');
214 ($exit,$description) = ('restart','restart server')
215 if $ENV{FREY_RESTART}; # tune labels on exit link
216
217 my $right =
218 qq|
219 <span class="right">
220 <a title="reload" href="/reload$url"><code>$url</code></a>
221 <a title="$description" href="/exit$url">$exit</a>
222 </span>
223 |;
224
225 my $revision = Frey::SVK->info->{Revision} || '';
226
227 my $html = join("\n",
228 qq|<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"><html><head>|,
229 $self->_head_html,
230 '<title>' . ( $self->title || $a->{title} || ref($self) ) . '</title>',
231 '<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">',
232 ( $a->{head} || '' ),
233 qq|
234 </head><body>
235 $body
236 <div class="frey-status-line">
237 <a href="/">Frey</a> $Frey::VERSION $revision
238 $status_line
239 $right
240 </div>
241 </body></html>
242 |,
243 );
244
245 warn "## >>> page ",length($html), " bytes\n" if $self->debug;
246
247 return $html;
248 }
249
250 =head2 editor
251
252 Create HTML editor link with optional line and title
253
254 my $html = $self->editor( $class, $line, $title );
255
256 =cut
257
258 sub editor {
259 my ( $self, $class, $line, $title ) = @_;
260 confess "need class" unless $class;
261 $line ||= 1;
262 qq|<a target="editor" href="/editor+$class+$line"| .
263 ( $title ? qq| title="$title"| : '' ) .
264 qq|>$class</a>|;
265 }
266
267 =head2 editor_links
268
269 Create HTML links to editor for perl error message
270
271 my $html = $self->editor_links( $error )
272
273 =cut
274
275 sub editor_links {
276 my ( $self, $error ) = @_;
277
278 $error =~ s{at\s+(\S+)\s+line\s+(\d+)}
279 {at <a target="editor" href="/editor+$1+$2">$1</a> line $2}gsm;
280
281 $error =~ s{(via package ")([\w:]+)(")}
282 {$1<a target="editor" href="/editor+$2+1">$2</a>$3}gsm;
283
284 return $error;
285 }
286
287 sub error {
288 my $self = shift;
289 my $error = join(" ", @_);
290
291 my @backtrace = $self->backtrace;
292 $error .= "\n\t" . join( "\n\t", @backtrace ) if @backtrace;
293
294 warn "ERROR: $error\n";
295 return
296 qq|<pre class="frey-error">|
297 . $self->editor_links( $error ) .
298 qq|</pre>|
299 ;
300 }
301
302 sub add_status {
303 my ( $self, $data ) = @_;
304 push @{ $self->status }, $data;
305 warn "## current status ", $#{ $self->status }, " elements";
306 }
307
308 1;

  ViewVC Help
Powered by ViewVC 1.1.26