$dump";
}
-sub dom2html {
-# warn "## dom2html ",dump( @_ );
- return Continuity::Widget::DomNode->create( @_ )->to_string;
+sub popup { my $self = shift; $self->popup_dropdown('popup', @_); }
+sub dropdown { my $self = shift; $self->popup_dropdown('dropdown', @_); }
+
+our $re_html = qr{<(?:!--|(\w+)|[^>]+)/?>}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|$content| unless $content =~ m{^\s*<(span|a|code).+?/\1>\s*};
+
+ $content =~ s{([^<]+)}{$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|$name $content\n|;
+ } elsif ( $name =~ s{^\s*($2$3]gs; # FIXME insert bless hiding back
+
+ # perl's backtrace
$error =~ s{at\s+(\S+)\s+line\s+(\d+)}
- {at $1 line $2}gsm;
+ {at $1 line $2}gsm;
+
+ $error =~ s{(via (?:package)\s+"?)([\w:]+)("?)}
+ {$1$2$3}gsm
+ || # or anything that looks like "Class::Name"
+ $error =~ s{"(\w+(?:::\w+)+)"}
+ {"$1"}gsm;
+
+ # method error messages
+ # FIXME replace with link to Frey::Introspect data
+ $error =~ s{(method ")(\w+)(" via)}
+ {$1$2$3}gsm;
+
+ # link paths to editor
+ $error =~ s{((?:lib|t)/[\S]+)\s+(\d+\s+bytes)}
+ {$1}gsm;
- $error =~ s{(via package ")([\w:]+)(")}
- {$1$2$3}gsm;
+ $error =~ s{(class ")([\w:]+)(")}
+ {$1$2$3}gsm;
return $error;
}
+sub html_self {
+ my $self = shift;
+ my $html = $self;
+ $html =~ s{([\w:]+)=}{$1=}gsm;
+ return $html;
+}
+
+=head2 error
+
+This method will return error to browser and backtrace unless
+error message ends with LF C<\n> just like L| - . $self->editor_links( $error ) . - qq|| - ; -} - -sub add_status { - my ( $self, $data ) = @_; - push @status, $data; -} + if ( $error !~ m{\n$} ) { + if ( my @backtrace = $self->backtrace ) { + $backtrace = + "\n" . $self->html_self . "->error backtrace\n\t" + . $self->html_links( join( "\n\t", @backtrace ) ) + ; + $fatal = qq| frey-fatal|; + } + } -sub clean_status { - @status = (); - $icon_html = ''; + warn "ERROR: $error\n"; + $self->add_icon('error'); + $error = $self->html_links( $error ); + return qq|
$error $backtrace| ; } -sub status_parts { - warn "## status parts ", dump( map { keys %$_ } @status ); -} +=head1 Status line -sub DEMOLISH { - my ( $self ) = @_; - warn "## $self DEMOLISH status ", $#status + 1, " elements ", dump( map { keys %$_ } @status ) if @status; -} +=head2 add_status -=head2 add_icon + $self->add_status( { name => { some => 'data' } } ); - Frey::Foo->add_icon; # /static/icons/Frey/Foo.png - Frey::Foo->add_icon('warning'); # /static/icons/Frey/Foo/warning.png + $self->add_status( "append to last status popup" ); =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"; - return $path; +sub add_status { + my ( $self, $data ) = @_; + die "no data" unless $data; + if ( ref $data ) { + push @status, $data; } else { - warn "TODO: add $path icon for $class"; - return undef; + if ( defined $status[ $#status ] ) { + $status[ $#status ]->{ '+' } = $data; + } else { + push @status, { '+' => $data }; + } } } -sub add_icon { - my ($self,$variant) = @_; +=head2 clean_status - my $class = ref($self); - $class = $self->class if $self->can('class'); - my $icon_path = $self->icon_path( $class, $variant ) || return; +Called at beginning of each request - $icon_html .= qq||; - warn "# using icon $icon_path"; + $self->setup_request; -=for later +=cut - # 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|| if -e $ico_path; +sub setup_request { + my ($self) = shift; + warn "## clean_status"; + @head = ( 'static/frey.css' ); + @status = ( + { 'ClassBrowser' => Frey::Class::Browser->new( usage_sort => 1, usage_on_top => 0 )->as_markup }, + { 'Bookmarklets' => Frey::Bookmarklet->new->as_markup }, + { 'INC' => Frey::INC->new->as_markup }, + ); +} + +=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 + my $warn_colors = { '#' => '#444', '##' => '#888', @@ -399,29 +526,65 @@ '"' => '"', }; +=for later + my $multiline_re = '[\\' . join('\\', keys %$multiline_markers ) . ']'; warn "## multiline markers ", dump( $multiline_markers ), " -> $multiline_re"; +=cut + sub log_path { - $Frey::Bootstrap::log_path || warn "no log_path?"; + $Frey::Bootstrap::log_path || die "no log_path?"; +} + +our $pwd = `pwd`; +chomp $pwd; + +sub strip_full_path { + my ($self, $msg) = @_; + # Mojo seems to expand warn messages to full path which is annoying + $msg =~ s{/[^/]+/\.\./}{/}gs; + $msg =~ s{$pwd/*}{}gs; + return $msg; } +our $last_log_pos = 0; +our $last_log_line = 0; + sub warnings_html { my ($self,$level) = shift; $level ||= $self->debug, my $path = $self->log_path; - my $warnings; - my $line = 0; + my $max = 30; + my $pos = 0; + my @warnings = ( '' x $max ); # XXX circualar buffer for 50 lines + my $line = $last_log_line; my $multiline_end; - open(my $log, '<', $path) || die "can't open $path: $!"; + # 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: $!"; + seek($log, $last_log_pos, 0) || warn "can't seek: $!"; while(<$log>) { chomp; $line++; + next if m{^\s+(Mojo|Class::MOP|Moose)::}; + 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"; @@ -438,27 +601,53 @@ next; } - $style = $warn_colors->{$1} - ? ' style="color:' . $warn_colors->{$1} . '"' - : ''; +=cut + if ( m{^(#*)} ) { + + my $level = $1; + my $msg = $self->strip_full_path( $_ ); - my $msg = $self->html_escape( $_ ); my $spacer = ' '; - if ( length($msg) > $self->html_dump_width ) { - $msg = substr( $msg, 0, $self->html_dump_width ); + 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 = '…' } - $msg =~ s{^\s}{ }g; - $warnings .= qq|
but CSS hates me
+
+ $msg = $self->html_escape( $msg );
+
+ if ( my $class = $level_to_class->{ $level } ) {
+ $msg = qq|$msg|;
+ }
+
+ #$msg .= $spacer . qq|$line\n|;
+ $msg = qq|$line$msg|
+ . ( $spacer ? $spacer : '' )
+ . "\n"; # XXX needs this
+
+ $warnings[ $pos++ % $max ] = $msg;
}
}
+ $last_log_pos = tell($log);
+ $last_log_line = $line;
+ warn "log has $line lines tell position $last_log_pos";
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
- qq|warn|
- . $self->editor_links( $warnings )
- . qq||
+ # need to wrap editor link into span so we can have links in warnings
+ qq|warn|
+ . $self->html_links( $warnings )
+ . qq||
;
}
@@ -475,7 +664,7 @@
my ($self) = @_;
my @backtrace;
- foreach ( 0 .. 5 ) {
+ foreach ( 1 .. 5 ) { # 0 = backtrace
my (
$package,$path,$line
# subroutine hasargs
@@ -484,10 +673,47 @@
) = caller($_) or last;
push @backtrace,
- qq|via $package from $path $path|;
+ qq|via "$package" at $path line $line|;
}
- warn "# backtrace: ", dump( @backtrace ) if @backtrace;
+ #warn "# backtrace: ", dump( @backtrace ) if @backtrace;
return @backtrace;
}
+=head2 checkbox
+
+Generate checkbox html markup from some attribute
+
+ my $html = $self->checkbox('attribute_name', $value);
+
+=cut
+
+sub checkbox {
+ my ($self,$name,$value) = @_;
+ my $checked = '';
+ my $all_checkboxes = eval { $self->$name };
+ warn "ERROR tried to get checkbox value for '$name' which is unknown: $@" if $@;
+ $all_checkboxes = [ $all_checkboxes ] unless ref($all_checkboxes) eq 'ARRAY'; # sigh, too chatty
+ $checked = ' checked' if grep { defined $_ && $_ eq $value } @$all_checkboxes;
+ warn "# checkbox $name $value $checked\t", $self->dump( $self->$name );
+ qq||;
+}
+
+=head2 strip
+
+Strip whitespace around content
+
+ my $stripped = strip(' no more whitespace around this ');
+
+=cut
+
+sub strip {
+ my $t = shift;
+ $t =~ s{^\s+}{}gs;
+ $t =~ s{>\s+<}{><}gs;
+ $t =~ s{\s+$}{}gs;
+ return $t;
+}
+
+no Moose::Role;
+
1;