--- trunk/lib/Frey/Web.pm	2008/11/19 19:11:52	465
+++ trunk/lib/Frey/Web.pm	2008/11/29 00:06:11	613
@@ -1,33 +1,25 @@
 package Frey::Web;
 use Moose::Role;
 
-with 'Frey::Backtrace';
+with 'Frey::Session';
 
 use Frey::Types;
 
-use Continuity::Widget::DomNode;
+#use Continuity::Widget::DomNode;
 use Data::Dump qw/dump/;
-use Carp qw/confess/;
+use Carp qw/confess cluck/;
 use File::Slurp;
 
 use Frey::Bookmarklet;
 use Frey::ClassBrowser;
+use Frey::INC;
 
-has 'head' => (
-	is => 'rw',
-	isa => 'ArrayRef[Str]',
-	default => sub { [ 'static/frey.css' ] },
-);
+use Frey::SVK;
 
-has 'status' => (
-	is => 'rw',
-	isa => 'ArrayRef[HashRef[Str]]',
-	lazy => 1,
-	default => sub { [
-		{ 'Bookmarklets' => Frey::Bookmarklet->new->as_markup },
-		{ 'ClassBrowser' => Frey::ClassBrowser->new( usage_on_top => 0 )->as_markup },
-	] },
-);
+use Text::Tabs; # expand, unexpand
+
+our @head;
+sub head { @head }
 
 has 'request_url' => (
 	is => 'rw',
@@ -49,24 +41,74 @@
 	is => 'rw',
 	isa => 'Str',
 	default => 'text/html',
+	documentation => 'Content-type header',
 );
 
-=head2 inline_smaller_than
-
-Inline JavaScript and CSS smaller than this size into page reducing
-round-trips to server.
-
-=cut
+has 'dump_max_bytes' => (
+	is => 'rw',
+	isa => 'Int',
+	default => 4096,
+	documentation => 'maximum dump size sent to browser before truncation',
+);
 
 has 'inline_smaller_than' => (
 	is => 'rw',
 	isa => 'Int',
 	default => 10240,
+	documentation => 'inline JavaScript and CSS to reduce round-trips',
+);
+
+has 'html_dump_width' => (
+	documentation => 'crop longer lines in dumps',
+	is => 'rw',
+	isa => 'Int',
+#	required => 1, # FIXME we can't have required fields with defaults because Frey::Action isn't smart enough and asks for them
+	default => 120,
 );
 
-sub dom2html {
-#	warn "## dom2html ",dump( @_ );
-	return Continuity::Widget::DomNode->create( @_ )->to_string;
+my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
+my $escape_re  = join '|' => keys %escape;
+
+sub html_escape {
+	my ( $self, $html ) = @_;
+	$html =~ s/($escape_re)/$escape{$1}/g;
+	return $html;
+}
+
+sub html_dump {
+	my ( $self, $dump ) = @_;
+	$dump = dump( $dump ) if ref($dump);
+	my $width = $self->html_dump_width;
+	$dump =~ s{(\n[^\n]{$width})([^\n]+?)([^\n]{5})}{\n$1...$3}gs;
+	$dump = $self->html_escape( $dump );
+	$dump =~ s{\Q...\E}{&hellip;}gs;
+#	$dump =~ $self->editor_links( $dump ); # FIXME include this
+	return "<code>$dump</code>";
+}
+
+sub popup    { my $self = shift; $self->popup_dropdown('popup',    @_); }
+sub dropdown { my $self = shift; $self->popup_dropdown('dropdown', @_); }
+
+our $re_html = qr{<(?:!--.+?--|(\w+).+?/\1|[^>]+/)>}s; # relaxed html check for one semi-valid tag
+
+sub popup_dropdown {
+	my ( $self, $type, $name, $content, $full ) = @_;
+
+	$content = $self->html_dump($content) if ref $content;
+
+	$content = qq|<span>$content</span>| unless $content =~ m{^\s*<(span|a|code).+?/\1>\s*};
+
+	$content =~ s{<span>(<code>[^<]+</code>)</span>}{$1} && $self->TODO("code wrapped in span");
+
+	warn "## $type [$name] = ", length( $content ), " bytes"; # if $self->debug; # FIXME
+
+	if ( $name =~ m{::} && $name !~ $re_html ) {
+		return qq|<a class="frey-$type" target="$name" href="/$name">$name $content</a>\n|;
+	} elsif ( $name =~ s{^\s*(<a)\s+}{$1 class="frey-$type"} ) {
+		return qq|$name $content\n|;
+	} else {
+		return qq|<span class="frey-$type">$name $content</span>\n|;
+	}
 }
 
 sub _inline_path {
@@ -77,15 +119,15 @@
 sub _head_html {
 	my $self = shift;
 	my $out = '';
-	foreach my $path ( @{ $self->head } ) {
+	foreach my $path ( @head ) {
 		$path =~ s!^/!!;
 		if ( $path =~ m/\.js$/ ) {
 			$out .= $self->_inline_path( $path ) ?
-				qq|<!-- $path --><script type="text/javascript">\n| . read_file($path) . qq|\n</script>| :
+				qq|<script type="text/javascript">\n/* inline $path */\n\n| . read_file($path) . qq|\n</script>| :
 				qq|<script type="text/javascript" src="/$path"></script>|;
 		} elsif ( $path =~ m/\.css$/ ) {
 			$out .= $self->_inline_path( $path ) ?
-				qq|<!-- $path --><style type="text/css">\n| . read_file( $path ) . qq|\n</style>| :
+				qq|<style type="text/css">\n/* inline $path */\n\n| . read_file( $path ) . qq|\n</style>| :
 				qq|<link type="text/css" rel="stylesheet" href="/$path" media="screen">|;
 		} elsif ( $path =~ m{<.+>}s ) {
 			$out .= $path;
@@ -112,11 +154,11 @@
 	return if ! defined $path || $path eq '';
 	$path =~ s!^/!!;
 
-	if ( $path =~ m{<.*>}s ) {
-		push @{ $self->head }, $path;
+	if ( $path =~ $re_html ) {
+		push @head, $path;
 	} elsif ( -e $path ) {
 		if ( $path =~ m/\.(?:js|css)$/ ) {
-			push @{ $self->head }, $path;
+			push @head, $path;
 		} else {
 			confess "can't add_head( $path ) it's not js or css";
 		}
@@ -127,6 +169,17 @@
 
 }
 
+sub add_css {
+	my ($self,$css) = @_;
+	my ( $package, $path, $line ) = caller;
+	$self->add_head( qq|
+	<style type="text/css">
+	/* via $package at $path line $line */
+	$css
+	</style>
+	| );
+}
+
 our $reload_counter = 0;
 
 
@@ -140,30 +193,24 @@
 
 =cut
 
+our @status;
+sub status { @status };
+
+our $icon_html;
+
 sub page {
 	my $self = shift;
 	my $a = {@_};
 
+	warn "## page ",dump($a);
+
 	$reload_counter++;
 
 	my $status_line = '';
-	foreach my $part ( @{ $self->status } ) {
-		if ( ref($part) ne 'HASH' ) {
-			warn "part not hash ",dump( $part ) ;
-			#$self->status( $part );
-			next;
-		}
+
+	foreach my $part ( @status ) {
 		foreach my $name ( keys %$part ) {
-			my $content = $part->{$name};
-			if ( ref($content) ) {
-				$content = '<code>' . dump($content) . '</code>';
-				my $l = length($content);
-				$content = qq|<span>$l bytes</span>| if $l > 1024;
-			} else {
-				$content = qq|<span>$content</span>|;
-			}
-			warn "### part [$name] = ", length( $content ), " bytes" if $self->debug;
-			$status_line .= qq|<span class="frey-popup">$name $content</span>\n|;
+			$status_line .= $self->popup( $name, $part->{$name} );
 		}
 	}
 
@@ -171,7 +218,11 @@
 	$url =~ s{\?reload=\d+}{};
 
 	my $body = $a->{body};
-	$body ||= $self->as_markup if $self->can('as_markup');
+	if ( ! $body ) {
+		my $run = $a->{run} || 'as_markup';
+		warn "# no body, invoke $self->$run on ", ref($self);
+		$body = $self->$run;
+	}
 	if ( $self->content_type !~ m{html} ) {
 		warn "# return only $self body ", $self->content_type;
 		return $body
@@ -180,19 +231,41 @@
 		$body = '<!-- no body -->';
 	}
 
+	$status_line .= $self->warnings_html;
+
+	my	($exit,$description) = ('exit','stop server');
+		($exit,$description) = ('restart','restart server')
+		if $ENV{FREY_RESTART}; # tune labels on exit link
+
+	my $right =
+		qq|
+			<span class="right">
+			<a title="reload $url"  href="/reload$url">reload</a>
+			<a title="$description" href="/exit$url">$exit</a>
+			</span>
+		|;
+
+	my $svk = Frey::SVK->new;
+	my $info = $svk->info;
+	my $revision = $svk->info->{Revision} || '';
+	$revision = $1 if $info->{'Mirrored From'} =~ m{Rev\.\s+(\d+)};
+
+	$self->add_icon unless $icon_html;
+
 	my $html = join("\n",
 		qq|<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"><html><head>|,
 		$self->_head_html,
 		'<title>' . ( $self->title || $a->{title} || ref($self) ) . '</title>',
 		'<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">',
+		( $icon_html || '<!-- no icon -->' ),
 		( $a->{head} || '' ),
 		qq|
 		</head><body>
 		$body
 		<div class="frey-status-line">
-			<a href="/">Frey</a> $Frey::VERSION
-			<a href="?reload=$reload_counter"><code>$url</code></a>
+			<a href="/">Frey</a> $Frey::VERSION $revision
 			$status_line
+			$right
 		</div>
 	    </body></html>
 		|,
@@ -203,6 +276,49 @@
 	return $html;
 }
 
+=head2 editor
+
+Create HTML editor link with optional line and title
+
+  my $html = $self->editor( $class, $line, $title );
+
+=cut
+
+sub editor {
+	my ( $self, $class, $line, $title ) = @_;
+	confess "need class" unless $class;
+	if ( ! defined $title ) {
+		$title  = "edit $class";
+		$title .= " line $line" if $line;
+	}
+	$line  ||= 1;
+	qq|<a target="editor" href="/editor+$class+$line"| .
+	( $title ? qq| title="$title"| : '' ) .
+	qq|>$class</a>|;
+}
+
+=head2 editor_links
+
+Create HTML links to editor for perl error message
+
+  my $html = $self->editor_links( $error )
+
+=cut
+
+sub editor_links {
+	my ( $self, $error ) = @_;
+
+#	$error =~ s[(bless\({\s+.+?\s+},\s+)("[^"]+")(\) at)][<span class="frey-dropdown">$1<code>$2</code>$3</span>]gs; # FIXME insert bless hiding back
+
+	$error =~ s{at\s+(\S+)\s+line\s+(\d+)}
+		{at <a target="editor" href="/editor+$1+$2">$1</a> line $2}gsm;
+
+	$error =~ s{(via (?:package) "?)([\w:]+)("?)}
+		{$1<a target="editor" href="/editor+$2+1">$2</a>$3}gsm;
+
+	return $error;
+}
+
 sub error {
 	my $self = shift;
 	my $error = join(" ", @_);
@@ -211,12 +327,264 @@
 	$error .= "\n\t" . join( "\n\t", @backtrace ) if @backtrace;
 
 	warn "ERROR: $error\n";
-	$error =~ s{at\s+(\S+)\s+line\s+(\d+)}
-		{at <a target="editor" href="/editor+$1+$2">$1</a> line $2}gsm;
-	$error =~ s{(via package ")([\w:]+)(")}
-		{$1<a target="editor" href="/editor+$2+1">$2</a>$3}gsm;
+	return
+		qq|<pre class="frey-error">|
+		. $self->editor_links( $error ) .
+		qq|</pre>|
+		;
+}
+
+=head1 Status line
+
+=head2 add_status
+
+  $self->add_status( { name => { some => 'data' } } );
 
-	return qq|<pre class="frey-error">$error</pre>|;
+  $self->add_status( "append to last status popup" );
+
+=cut
+
+sub add_status {
+	my ( $self, $data ) = @_;
+	push @status, { 'X' => [ $self->backtrace ] };
+	if ( ref($data) ) {
+		push @status, $data;
+	} else {
+		if ( defined $status[ $#status ] ) {
+			$status[ $#status ]->{ '+' } = $data;
+		} else {
+			push @status, { '+' => $data };
+		}
+	}
+}
+
+=head2 clean_status
+
+Called at beginning of each request
+
+  $self->clean_status;
+
+=cut
+
+sub clean_status {
+	my ($self) = shift;
+	@head = ( 'static/frey.css' );
+	@status = (
+		{ 'ClassBrowser' => Frey::ClassBrowser->new( usage_on_top => 0 )->as_markup },
+		{ 'Bookmarklets' => Frey::Bookmarklet->new->as_markup },
+		{ 'INC' => Frey::INC->new->as_markup },
+	);
+	$icon_html = '';
+}
+
+=head2 status_parts
+
+Dump all status line parts
+
+  $self->status_parts
+
+=cut
+
+sub status_parts {
+	warn "## status parts ", dump( map { keys %$_ } @status );
+}
+
+=for debug
+
+sub DEMOLISH {
+	my ( $self ) = @_;
+	warn "## $self DEMOLISH status ", $#status + 1, " elements ", dump( map { keys %$_ } @status ) if @status;
+}
+
+=cut
+
+=head2 add_icon
+
+  Frey::Foo->add_icon;            # /static/icons/Frey/Foo.png
+  Frey::Foo->add_icon('warning'); # /static/icons/Frey/Foo/warning.png
+
+=cut
+
+sub icon_path {
+	my ($self,$class,$variant) = @_;
+	my $icon = $class;
+	$icon =~ s{::}{/}g;
+	$icon .= "/$variant" if $variant;
+	my $path = 'static/icons/' . $icon . '.png';
+	if ( -e $path ) {
+		warn "# $class from $self icon_path $path" if $self->debug;
+		return $path;
+	} else {
+		$self->TODO( "add $path icon for $class" );
+		return undef;
+	}
+}
+
+sub add_icon {
+	my ($self,$variant) = @_;
+
+	my $class = ref($self);
+	$class = $self->class if $self->can('class');
+	my $icon_path = $self->icon_path( $class, $variant ) || return;
+
+	$icon_html .= qq|<link rel="icon" type="image/png" href="/$icon_path">|;
+	warn "# using icon $icon_path";
+
+=for later
+
+	# FIXME http://en.wikipedia.org/wiki/Favicon suggest just rel="icon" but that doesn't seem to work!
+	my $ico_path = $icon_path;
+	$ico_path =~ s{png$}{ico};
+	if ( ! -e $ico_path ) {
+		system "convert $icon_path $ico_path";
+		warn "# convert $icon_path $ico_path : $@";
+	}
+	$icon_html .= qq|<link rel="shortcut icon" type="image/x-icon" href="/$ico_path">| if -e $ico_path;
+
+=cut
+
+}
+
+my $warn_colors = {
+	'#'  => '#444',
+	'##' => '#888',
+};
+
+my $multiline_markers = {
+	'(' => ')',
+	'{' => '}',
+	'[' => ']',
+	'"' => '"',
+};
+
+my $multiline_re = '[\\' . join('\\', keys %$multiline_markers ) . ']';
+warn "## multiline markers ", dump( $multiline_markers ), " -> $multiline_re";
+
+sub log_path {
+	$Frey::Bootstrap::log_path || warn "no log_path?";
+}
+
+sub warnings_html {
+	my ($self,$level) = shift;
+	$level ||= $self->debug,
+	my $path = $self->log_path;
+
+	my $max = 30;
+	my $pos = 0;
+	my @warnings = ( '' x $max ); # XXX circualar buffer for 50 lines
+	my $line = 0;
+	my $multiline_end;
+
+	# XXX do we really want to do this every time?
+	my $css = qq|/* short css classes for levels */\n|;
+	my $level_to_class;
+	foreach ( keys %$warn_colors ) {
+		my $l = length($_);
+		my $class = 'l' . $l;
+		$css .= qq|.$class { color: $warn_colors->{$_} }\n|;
+		$level_to_class->{ $_ } = $class;
+	}
+	$self->add_css( $css );
+
+	open(my $log, '<', $path) || die "can't open $path: $!";
+	while(<$log>) {
+		chomp;
+		$line++;
+
+		my $style = '';
+
+=for filter
+
+		if ( $multiline_end ) {
+			if ( m{^\Q$multiline_end\E} || m{^\s.+\Q$multiline_end\E;$} ) {
+#				warn "## $line end of $multiline_end in '$_'\n";
+				undef $multiline_end;
+			} else {
+#				warn "## $line skipped\n";
+			}
+		} elsif ( m{^(#*)\s+} ) {
+			my $l = $1 ? length($1) : 0;
+			if ( $l > $level ) {
+				undef $multiline_end;
+				$multiline_end = $multiline_markers->{$1} if m{($multiline_re)$};
+#				warn "## $line start $1 .. $multiline_end level $l > $level for '$_'\n" if $multiline_end;
+				next;
+			}
+
+=cut
+		if ( m{^(#*)} ) {
+
+			my $level = $1;
+			my $msg = $_;
+
+			my $spacer = ' ';
+			my $real_msg = expand( $msg );
+			if ( length($real_msg) > $self->html_dump_width ) {
+				
+				$real_msg = substr( $msg, 0, $self->html_dump_width );
+				$msg = unexpand( $real_msg );
+				$spacer = '&hellip;'
+			}
+
+			$msg = $self->html_escape( $msg );
+
+			if ( my $class = $level_to_class->{ $level } ) {
+				$msg = qq|<span class="$class">$msg</span>|;
+			}
+
+			#$msg .= $spacer . qq|<a target="editor" href="/editor+$path+$line" style="float: right;">$line</a>\n|;
+			$msg = qq|<a target="editor" href="/editor+$path+$line" style="float: right;">$line</a>$msg|
+				. ( $spacer ? $spacer : '' )
+				. "\n"; # XXX <pre> needs this
+
+			$warnings[ $pos++ % $max ] = $msg;
+		}
+	}
+	warn "log has $line lines tell position ",tell($log);
+	close($log) || die "can't close $path: $!";
+
+	my $size = -s $path;
+
+	my $warnings = join("",
+		map { $warnings[ ( $pos + $_ ) % $max ] || '' } 0 .. ( $max - 1 )
+	);
+
+	my $s = length($warnings);
+
+	return
+		# need to wrap editor link into span so we can have links in warnings
+		  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>|
+		. $self->editor_links( $warnings )
+		. qq|</code></span></a>|
+		;
+}
+
+
+=head2 backtrace
+
+Show backtrace with links to editor
+
+  my @backtrace = $self->backtrace;
+
+=cut
+
+sub backtrace {
+	my ($self) = @_;
+
+	my @backtrace;
+	foreach ( 0 .. 5 ) {
+		my (
+			$package,$path,$line
+			# subroutine hasargs
+			# wantarray evaltext is_require
+			# hints bitmask hinthash
+		) = caller($_) or last;
+
+		push @backtrace,
+			qq|via $package at $path line $line|;
+	}
+	#warn "# backtrace: ", dump( @backtrace ) if @backtrace;
+	return @backtrace;
 }
 
 1;