lib/Frey/Introspect.pm

package Frey::Introspect;

use Moose;
use Carp;
#use Moose::Meta::Role;
#use Moose::Meta::Class;
use Data::Dump qw/dump/;
use File::Slurp;
use List::Util;

use PPI;
use PPI::HTML;

use lib 'lib';
use Frey::Pod;

extends 'Frey::PPI';
with 'Frey::Web';
with 'Frey::Storage';

=head1 DESCRIPTION

Provide introspection on any perl class installed on system

=cut

has 'class' => (
        is => 'rw',
        isa => 'Str',
        required => 1,
);

=head2 joose

  my $js = $o->joose;

=cut

sub joose {
        my ($self) = @_;

        my ( $meta, $is_role ) = $self->class_meta;

        if ( ! $is_role ) {
                my @superclasses = map{ $_->meta->name }
                        grep { $_ ne 'Moose::Object' } $meta->superclasses;
                warn "superclasses ",dump( @superclasses ) if $self->debug;
        }

        my $out;

        my ( $m, $c ) = split(/::/, $self->class, 2);
        my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';

        $c ||= '';

        $out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";

        foreach ( $meta->get_attribute_list ) {
                $out .= "\t\t\t$_: {\n";

                my $attr = $meta->get_attribute($_);
                my $is = eval { $attr->_is_metadata; };
                return if $@;

                $out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
                $out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
                $out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
                $out .= "\t\t\t\tinit: \"" . $attr->init_arg . "\",\n" if $attr->init_arg;      # FIXME

                if( defined(my $isa = $attr->_isa_metadata) ){
                        if( blessed $isa ){
                                while( blessed $isa ){
                                        $isa = $isa->name;
                                }
                        }
                        $isa =~ s/\s+\|\s+undef//gi;
                        $out .= "\t\t\t\tisa: Moose.$isa,\n";
                }


                $out .= "\t\t\t},\n";

        }

        $out .= "\t\t},\n\t\tmeta: Frey.HTML,
                classMethods: {
                        renderHTML: function () {
                                return new Joose.SimpleRequest().getText(\"/" . $self->class . "\")
                        },\n";

        $out .= "\t\t},\n";

        $out .= "\t}),\n";

        $out =~ s/,\n$/\n/;
        $out .= "});\n";

        $out .= "\nconsole.log( 'loaded " . $self->class . " from $filename' );\n";

        warn "method_list = ",dump( $meta->get_method_list ) if $self->debug;

#       print $out;
        my $path = "static/blib/$filename";
        write_file( $path, $out );
        warn "# created $path\n";

        return $out;
}

sub as_markup {
        my ( $self ) = @_;

        my ( $meta, $is_role ) = $self->class_meta;

        my $class = $self->class;
        $self->title( $class );

        my $introspect_path = "var/introspect/$class.yaml";
        $self->mkbasepath( $introspect_path );
        my $introspect; # FIXME update with = $self->load( $introspect_path );

        my ( $superclasses, $roles ) = ( '<b>Role</b>', '' );
        if ( ! $is_role ) {
                if ( $meta->superclasses ) {
                        $superclasses = 'Superclasses: ' .
                                join(', ',
                                        map {
                                                my $name = $_->meta->name;
                                                $introspect->{superclass}->{$name} = {};

                                                qq|<a target="$name" href="/$name" title="introspect $name">$name</a>| .
                                                $self->dropdown( qq|<sup>?</sup>|, $_->meta )
                                        }
                                        #grep { $_ ne 'Moose::Object' }
                                        $meta->superclasses
                                );
                }
        }

        my $method_from_role;
        my $attribute_from_role;

        if ( $meta->can('roles') ) {
                my $role_nr = 1;
                $roles = join(' ',
                        grep { ! m/\Q$class\E/ }        # skip me
                        map {
                                my $r = '';
                                foreach my $name ( split(/\|/, $_->name) ) {
                                        $introspect->{roles}->{$name} = {};
                                        $method_from_role->{    $_ }->{$name} = $role_nr foreach $_->get_method_list;
                                        $attribute_from_role->{ $_ }->{$name} = $role_nr foreach $_->get_attribute_list;

                                        $r .=
                                          qq|<a target="$name" href="/$name" title="introspect $name">$name</a>|
        #                               . qq|<sup>| . $self->dropdown( $role_nr++, $name->meta ) . qq|</sup>|
                                        . $self->dropdown(
                                                qq|<sup>| . $role_nr++ . qq|</sup>|,
                                                $name->meta
                                        )
                                        ;
                                }
                                $r;
                        }
                        $meta->calculate_all_roles
                );
                $roles = qq|with roles: $roles| if $roles;
        }
        warn "# method_from_role ",dump( $method_from_role );

        my @methods;
        @methods = map {
                my $name = $_;
                if ( $method_from_role->{$name} ) {
                        my ( $role_name, $nr ) = each %{ $method_from_role->{$name} };
                        $introspect->{methods}->{$name}->{role} = $role_name;
                        $name .= qq|<sup title="$role_name">$nr</sup>|;
                } else {
                        $introspect->{methods}->{$name} = {};
                }
                qq|<td class="m">$name</td>|
        } sort {
                lc($a) cmp lc($b)       
        } $self->class_methods( $class );

        my @attributes;
        if ( $meta->get_attribute_list ) {
                @attributes = map {
                        my $name = $_;
                        $introspect->{attribute}->{$name} = {}; 
                        my $html_name = $name;
                        my $attr = $meta->get_attribute($name);
                        confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;
                        warn "## attr $name ref ",ref( $attr ) if $self->debug;

                        my ( $title, $properties ) = ( '', '' );
                        if ( $attr->can('is_required') && $attr->is_required ) {
                                ( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' );
                                $introspect->{attribute}->{$name}->{required} = 1;
                        }

                        foreach my $check ( qw/has_type_constraint has_handles is_weak_ref is_required is_lazy should_coerce should_auto_deref has_default has_trigger has_applied_traits/ ) {
                                my $getter;
                                
                                $getter = $check;
                                $getter =~ s/^has_//;
                                
                                if ( $attr->can($check) && $attr->$check ) {
                                        $properties .= $check;
                                        # we need our dump here instead of $attr->$getter->dump because default can return scalar
                                        my $v = $attr->$getter;
                                        $properties .= ref($v)
                                                ? $self->dropdown( qq|<sup>?</sup>|, $attr->$getter )
                                                : qq| <code>$v</code>|
                                                ;
                                }
                                $properties .= ' ';
                        }
                        my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';

                        if ( $attribute_from_role->{$name} ) {
                                my ( $role_name, $nr ) = each %{ $attribute_from_role->{$name} };
                                $name .= qq|<sup title="$role_name">$nr</sup>|;
                        }

                        if ( my $doc = eval { $attr->documentation } ) {
                                $properties = qq|
                                        $properties
                                        <span class="documentation">$doc</span>
                                |;
                                $self->add_css(qq|
                                        span.documentation {
                                                background: #eee;
                                                padding: 0.25em;
                                                float: left;
                                                clear: left;
                                        }
                                |);
                                $introspect->{action}->{$name}->{documentation} = $doc;
                        }

                        qq|<td class="a">$html_name</td><td class="t">$type</td><td class="p">$properties</td>|
                } sort $meta->get_attribute_list
        }

        my $table = qq|<table class="frey-introspect"><tr><th class="m">Methods</th><th class="a">Attributes</th><th>Type</th><th class="p">Properties</th></tr>|;
        while ( @methods || @attributes ) {
                my ($m,$a) = ( shift @methods, shift @attributes );
                $m ||= '<td></td>';
                $a ||= '<td></td>';
                $table .= qq|<tr>$m$a</tr>|;
        }
        $table .= qq|</table>|;

        my $path = $self->class_path( $class );

        my ( $pod_toc, $pod ) = Frey::Pod->new( class => $class, request_url => $self->request_url )->as_markup;
        return $pod_toc . $pod if $path =~ m{\.pod};

        warn "# ", $pod_toc ? 'toc' : '', ' ', $pod ? 'pod' : '';

        my $Document = PPI::Document->new( $path );

        # Create a reusable syntax highlighter
        my $Highlight = PPI::HTML->new(
                line_numbers => 1,
#               page => 1,
#               colors => {
#                       line_number => '#CCCCCC',
#                       number      => '#990000',
#               },
        );

        # Spit out the HTML
        my $source = $Highlight->html( $Document );

        $source =~ s{(<span.*?line_number.*>\s*)(\d+)(:\s*</span>)}{$1<a target="editor" href="/editor+$path+$2">$2</a>$3}g;

        # strip page html
#       $source =~ s{^.*<body[^>]+>}{}s;
#       $source =~ s{</body.*$}{}s;

        my $runnable = join("</dd><dd>",
                map {
                        $introspect->{runnable}->{$_} = {};
                        my $short = $_;
                        $short =~ s{_as_(?:markup|data|sponge)$}{};
                        qq|<a target="$class" href="/$class/$_" title="/$class/$_">$short</a>|
                } $self->class_runnable( $class )
        );
        $runnable = "<dt>runnable</dt><dd>$runnable</dd>" if $runnable;

        my $has_tests = '';
        my @tests = sort { lc($a) cmp lc($b) } grep { defined $_ } $self->has_tests;
        if ( @tests ) {
                $has_tests
                        = qq|<dt>test|
                        . ( $#tests > 0 ? 's' : '' )
                        . qq|<dt><dd>|
                        . join("</dd><dd>", map {
                                qq|<a target="$class" href="/Frey::Test::Runner/as_markup?test=$_">$_</a>|
                        } @tests )
                        . qq|</dd>|
                        ;
                $introspect->{tests} = [ @tests ],
        }

        my $includes = '';
        if ( my $inc = $self->includes ) {
                $introspect->{includes} = $inc;
                foreach my $type ( keys %$inc ) {
                        $includes
                                .= ucfirst($type)
                                . qq|: |
                                . join("\n",
                                        map {
                                                qq|<a target="$_" href="/$_">$_</a>|
                                        } @{
                                                $inc->{$type}
                                        }
                                )
                                ;
                }
        }

        $self->store( $introspect_path, $introspect );

        $self->add_css(qq|
                .frey-introspect-right {
                        position: fixed;
                        top: 1em;
                        right: 1em;
                        z-index: 10;
                        background: #ffc;
                        padding: 0.5em;
                        width: 20%;
                        font-size: 80%;
                }
                .frey-introspect-right dl dd {
                        margin-left: 1em;
                }

                /* fix pod */
                .frey-introspect-right dd ul {
                        padding-left: 0;
                }
                .frey-introspect-right dl ul > li {
                        list-style: none;
                }
        |);

        my $has_pod = qq|
                <dt><a href="#___top" title="Skip to POD">pod</a></dt>
                <dd>$pod_toc</dd>
        | if $pod_toc;

        my $has_source = qq|
                <dt><a href="#source" title="Skip to source">source</a></dt>
        | if $source;

        my $right = qq|
                <dl>
                $runnable
                $has_tests
                $has_pod
                $has_source
                </dl>
        |;


        return
                qq|
                        <h1>$class</h1>
                        <div class="frey-introspect">
                                $superclasses $roles
                                <br>$includes
                        </div>
                        <div class="frey-introspect-right">
                                $right
                        </div>
                        $table
                        $pod
                        </div>

                        <h1>Source</h1><a name="source"></a>
                        <div class="frey-source">$source</div>
                |
                ;
}

=head1 SEE ALSO

L<MooseX::AutoDoc> on which this code is based

=cut

1;
1	dpavlin	49	package Frey::Introspect;
2
3			use Moose;
4			use Carp;
5	dpavlin	100	#use Moose::Meta::Role;
6			#use Moose::Meta::Class;
7	dpavlin	49	use Data::Dump qw/dump/;
8			use File::Slurp;
9	dpavlin	51	use List::Util;
10	dpavlin	49
11	dpavlin	380	use PPI;
12			use PPI::HTML;
13
14	dpavlin	733	use lib 'lib';
15	dpavlin	631	use Frey::Pod;
16
17	dpavlin	496	extends 'Frey::PPI';
18	dpavlin	100	with 'Frey::Web';
19	dpavlin	602	with 'Frey::Storage';
20	dpavlin	49
21	dpavlin	943	=head1 DESCRIPTION
22
23			Provide introspection on any perl class installed on system
24
25			=cut
26
27	dpavlin	270	has 'class' => (
28	dpavlin	49	is => 'rw',
29			isa => 'Str',
30			required => 1,
31			);
32
33	dpavlin	53	=head2 joose
34
35	dpavlin	137	my $js = $o->joose;
36	dpavlin	53
37			=cut
38
39			sub joose {
40			my ($self) = @_;
41
42	dpavlin	308	my ( $meta, $is_role ) = $self->class_meta;
43	dpavlin	53
44			if ( ! $is_role ) {
45	dpavlin	50	my @superclasses = map{ $_->meta->name }
46			grep { $_ ne 'Moose::Object' } $meta->superclasses;
47	dpavlin	100	warn "superclasses ",dump( @superclasses ) if $self->debug;
48	dpavlin	50	}
49	dpavlin	49
50			my $out;
51
52	dpavlin	270	my ( $m, $c ) = split(/::/, $self->class, 2);
53	dpavlin	51	my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';
54	dpavlin	49
55	dpavlin	137	$c \|\|= '';
56
57	dpavlin	49	$out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";
58
59	dpavlin	137	foreach ( $meta->get_attribute_list ) {
60	dpavlin	49	$out .= "\t\t\t$_: {\n";
61
62	dpavlin	137	my $attr = $meta->get_attribute($_);
63	dpavlin	972	my $is = eval { $attr->_is_metadata; };
64			return if $@;
65
66	dpavlin	50	$out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
67			$out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
68			$out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
69			$out .= "\t\t\t\tinit: \"" . $attr->init_arg . "\",\n" if $attr->init_arg; # FIXME
70
71			if( defined(my $isa = $attr->_isa_metadata) ){
72			if( blessed $isa ){
73			while( blessed $isa ){
74			$isa = $isa->name;
75			}
76			}
77			$isa =~ s/\s+\\|\s+undef//gi;
78			$out .= "\t\t\t\tisa: Moose.$isa,\n";
79			}
80
81
82	dpavlin	49	$out .= "\t\t\t},\n";
83
84			}
85
86	dpavlin	51	$out .= "\t\t},\n\t\tmeta: Frey.HTML,
87			classMethods: {
88			renderHTML: function () {
89	dpavlin	292	return new Joose.SimpleRequest().getText(\"/" . $self->class . "\")
90	dpavlin	51	},\n";
91
92	dpavlin	49	$out .= "\t\t},\n";
93
94			$out .= "\t}),\n";
95	dpavlin	50
96			$out =~ s/,\n$/\n/;
97	dpavlin	49	$out .= "});\n";
98
99	dpavlin	270	$out .= "\nconsole.log( 'loaded " . $self->class . " from $filename' );\n";
100	dpavlin	49
101	dpavlin	137	warn "method_list = ",dump( $meta->get_method_list ) if $self->debug;
102	dpavlin	49
103	dpavlin	51	# print $out;
104	dpavlin	49	my $path = "static/blib/$filename";
105			write_file( $path, $out );
106			warn "# created $path\n";
107	dpavlin	51
108			return $out;
109	dpavlin	49	}
110
111	dpavlin	455	sub as_markup {
112	dpavlin	269	my ( $self ) = @_;
113	dpavlin	53
114	dpavlin	308	my ( $meta, $is_role ) = $self->class_meta;
115	dpavlin	53
116	dpavlin	270	my $class = $self->class;
117	dpavlin	802	$self->title( $class );
118	dpavlin	54
119	dpavlin	602	my $introspect_path = "var/introspect/$class.yaml";
120			$self->mkbasepath( $introspect_path );
121	dpavlin	735	my $introspect; # FIXME update with = $self->load( $introspect_path );
122	dpavlin	602
123	dpavlin	310	my ( $superclasses, $roles ) = ( '<b>Role</b>', '' );
124			if ( ! $is_role ) {
125			if ( $meta->superclasses ) {
126			$superclasses = 'Superclasses: ' .
127			join(', ',
128			map {
129			my $name = $_->meta->name;
130	dpavlin	733	$introspect->{superclass}->{$name} = {};
131	dpavlin	943
132			qq\|<a target="$name" href="/$name" title="introspect $name">$name</a>\| .
133			$self->dropdown( qq\|<sup>?</sup>\|, $_->meta )
134	dpavlin	310	}
135			#grep { $_ ne 'Moose::Object' }
136			$meta->superclasses
137			);
138			}
139			}
140
141	dpavlin	733	my $method_from_role;
142			my $attribute_from_role;
143	dpavlin	310
144			if ( $meta->can('roles') ) {
145			my $role_nr = 1;
146			$roles = join(' ',
147			grep { ! m/\Q$class\E/ } # skip me
148			map {
149	dpavlin	1125	my $r = '';
150			foreach my $name ( split(/\\|/, $_->name) ) {
151			$introspect->{roles}->{$name} = {};
152			$method_from_role->{ $_ }->{$name} = $role_nr foreach $_->get_method_list;
153			$attribute_from_role->{ $_ }->{$name} = $role_nr foreach $_->get_attribute_list;
154	dpavlin	943
155	dpavlin	1125	$r .=
156			qq\|<a target="$name" href="/$name" title="introspect $name">$name</a>\|
157			# . qq\|<sup>\| . $self->dropdown( $role_nr++, $name->meta ) . qq\|</sup>\|
158			. $self->dropdown(
159			qq\|<sup>\| . $role_nr++ . qq\|</sup>\|,
160			$name->meta
161			)
162			;
163			}
164			$r;
165	dpavlin	310	}
166			$meta->calculate_all_roles
167			);
168	dpavlin	943	$roles = qq\|with roles: $roles\| if $roles;
169	dpavlin	310	}
170	dpavlin	733	warn "# method_from_role ",dump( $method_from_role );
171	dpavlin	310
172	dpavlin	269	my @methods;
173	dpavlin	310	@methods = map {
174	dpavlin	313	my $name = $_;
175	dpavlin	733	if ( $method_from_role->{$name} ) {
176			my ( $role_name, $nr ) = each %{ $method_from_role->{$name} };
177			$introspect->{methods}->{$name}->{role} = $role_name;
178	dpavlin	313	$name .= qq\|<sup title="$role_name">$nr</sup>\|;
179	dpavlin	733	} else {
180			$introspect->{methods}->{$name} = {};
181	dpavlin	310	}
182	dpavlin	313	qq\|<td class="m">$name</td>\|
183	dpavlin	884	} sort {
184			lc($a) cmp lc($b)
185			} $self->class_methods( $class );
186	dpavlin	53
187	dpavlin	269	my @attributes;
188			if ( $meta->get_attribute_list ) {
189	dpavlin	409	@attributes = map {
190	dpavlin	313	my $name = $_;
191	dpavlin	733	$introspect->{attribute}->{$name} = {};
192	dpavlin	582	my $html_name = $name;
193	dpavlin	313	my $attr = $meta->get_attribute($name);
194	dpavlin	416	confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;
195	dpavlin	393	warn "## attr $name ref ",ref( $attr ) if $self->debug;
196	dpavlin	582
197			my ( $title, $properties ) = ( '', '' );
198	dpavlin	733	if ( $attr->can('is_required') && $attr->is_required ) {
199			( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' );
200			$introspect->{attribute}->{$name}->{required} = 1;
201			}
202	dpavlin	582
203			foreach my $check ( qw/has_type_constraint has_handles is_weak_ref is_required is_lazy should_coerce should_auto_deref has_default has_trigger has_applied_traits/ ) {
204	dpavlin	269	my $getter;
205
206			$getter = $check;
207			$getter =~ s/^has_//;
208
209	dpavlin	416	if ( $attr->can($check) && $attr->$check ) {
210	dpavlin	943	$properties .= $check;
211			# we need our dump here instead of $attr->$getter->dump because default can return scalar
212			my $v = $attr->$getter;
213			$properties .= ref($v)
214			? $self->dropdown( qq\|<sup>?</sup>\|, $attr->$getter )
215			: qq\| <code>$v</code>\|
216			;
217	dpavlin	197	}
218	dpavlin	582	$properties .= ' ';
219	dpavlin	269	}
220	dpavlin	416	my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';
221	dpavlin	313
222	dpavlin	733	if ( $attribute_from_role->{$name} ) {
223			my ( $role_name, $nr ) = each %{ $attribute_from_role->{$name} };
224	dpavlin	313	$name .= qq\|<sup title="$role_name">$nr</sup>\|;
225			}
226
227	dpavlin	735	if ( my $doc = eval { $attr->documentation } ) {
228			$properties = qq\|
229			$properties
230			<span class="documentation">$doc</span>
231			\|;
232			$self->add_css(qq\|
233			span.documentation {
234			background: #eee;
235			padding: 0.25em;
236	dpavlin	736	float: left;
237			clear: left;
238	dpavlin	735	}
239			\|);
240			$introspect->{action}->{$name}->{documentation} = $doc;
241			}
242	dpavlin	582
243	dpavlin	943	qq\|<td class="a">$html_name</td><td class="t">$type</td><td class="p">$properties</td>\|
244	dpavlin	727	} sort $meta->get_attribute_list
245	dpavlin	269	}
246	dpavlin	54
247	dpavlin	312	my $table = qq\|<table class="frey-introspect"><tr><th class="m">Methods</th><th class="a">Attributes</th><th>Type</th><th class="p">Properties</th></tr>\|;
248	dpavlin	269	while ( @methods \|\| @attributes ) {
249			my ($m,$a) = ( shift @methods, shift @attributes );
250			$m \|\|= '<td></td>';
251			$a \|\|= '<td></td>';
252			$table .= qq\|<tr>$m$a</tr>\|;
253			}
254			$table .= qq\|</table>\|;
255
256	dpavlin	688	my $path = $self->class_path( $class );
257
258	dpavlin	1034	my ( $pod_toc, $pod ) = Frey::Pod->new( class => $class, request_url => $self->request_url )->as_markup;
259			return $pod_toc . $pod if $path =~ m{\.pod};
260	dpavlin	134
261	dpavlin	1034	warn "# ", $pod_toc ? 'toc' : '', ' ', $pod ? 'pod' : '';
262
263	dpavlin	406	my $Document = PPI::Document->new( $path );
264	dpavlin	380
265			# Create a reusable syntax highlighter
266			my $Highlight = PPI::HTML->new(
267	dpavlin	406	line_numbers => 1,
268	dpavlin	380	# page => 1,
269			# colors => {
270			# line_number => '#CCCCCC',
271			# number => '#990000',
272			# },
273			);
274
275			# Spit out the HTML
276			my $source = $Highlight->html( $Document );
277
278	dpavlin	407	$source =~ s{(<span.?line_number.>\s)(\d+)(:\s</span>)}{$1<a target="editor" href="/editor+$path+$2">$2</a>$3}g;
279	dpavlin	406
280			# strip page html
281	dpavlin	380	# $source =~ s{^.*<body[^>]+>}{}s;
282			# $source =~ s{</body.*$}{}s;
283
284	dpavlin	1022	my $runnable = join("</dd><dd>",
285	dpavlin	458	map {
286	dpavlin	733	$introspect->{runnable}->{$_} = {};
287	dpavlin	662	my $short = $_;
288			$short =~ s{_as_(?:markup\|data\|sponge)$}{};
289			qq\|<a target="$class" href="/$class/$_" title="/$class/$_">$short</a>\|
290	dpavlin	458	} $self->class_runnable( $class )
291	dpavlin	409	);
292	dpavlin	1022	$runnable = "<dt>runnable</dt><dd>$runnable</dd>" if $runnable;
293	dpavlin	128
294	dpavlin	496	my $has_tests = '';
295	dpavlin	1034	my @tests = sort { lc($a) cmp lc($b) } grep { defined $_ } $self->has_tests;
296	dpavlin	635	if ( @tests ) {
297	dpavlin	1022	$has_tests
298			= qq\|<dt>test\|
299			. ( $#tests > 0 ? 's' : '' )
300			. qq\|<dt><dd>\|
301			. join("</dd><dd>", map {
302			qq\|<a target="$class" href="/Frey::Test::Runner/as_markup?test=$_">$_</a>\|
303			} @tests )
304			. qq\|</dd>\|
305			;
306	dpavlin	943	$introspect->{tests} = [ @tests ],
307	dpavlin	496	}
308
309	dpavlin	943	my $includes = '';
310			if ( my $inc = $self->includes ) {
311			$introspect->{includes} = $inc;
312			foreach my $type ( keys %$inc ) {
313			$includes
314			.= ucfirst($type)
315			. qq\|: \|
316			. join("\n",
317			map {
318			qq\|<a target="$_" href="/$_">$_</a>\|
319			} @{
320			$inc->{$type}
321			}
322			)
323			;
324			}
325			}
326
327			$self->store( $introspect_path, $introspect );
328
329	dpavlin	993	$self->add_css(qq\|
330	dpavlin	1034	.frey-introspect-right {
331	dpavlin	993	position: fixed;
332			top: 1em;
333			right: 1em;
334			z-index: 10;
335	dpavlin	1022	background: #ffc;
336			padding: 0.5em;
337			width: 20%;
338			font-size: 80%;
339	dpavlin	993	}
340	dpavlin	1034	.frey-introspect-right dl dd {
341	dpavlin	1022	margin-left: 1em;
342			}
343	dpavlin	1034
344			/* fix pod */
345			.frey-introspect-right dd ul {
346			padding-left: 0;
347			}
348			.frey-introspect-right dl ul > li {
349			list-style: none;
350			}
351	dpavlin	993	\|);
352
353	dpavlin	1034	my $has_pod = qq\|
354			<dt><a href="#___top" title="Skip to POD">pod</a></dt>
355			<dd>$pod_toc</dd>
356			\| if $pod_toc;
357	dpavlin	1018
358	dpavlin	1034	my $has_source = qq\|
359			<dt><a href="#source" title="Skip to source">source</a></dt>
360			\| if $source;
361
362			my $right = qq\|
363			<dl>
364			$runnable
365			$has_tests
366			$has_pod
367			$has_source
368			</dl>
369			\|;
370
371
372	dpavlin	1018	return
373	dpavlin	993	qq\|
374			<h1>$class</h1>
375			<div class="frey-introspect">
376			$superclasses $roles
377			<br>$includes
378			</div>
379	dpavlin	1034	<div class="frey-introspect-right">
380	dpavlin	1017	$right
381	dpavlin	993	</div>
382			$table
383			$pod
384			</div>
385
386			<h1>Source</h1><a name="source"></a>
387			<div class="frey-source">$source</div>
388	dpavlin	1018	\|
389			;
390	dpavlin	53	}
391
392	dpavlin	49	=head1 SEE ALSO
393
394			L<MooseX::AutoDoc> on which this code is based
395
396			=cut
397
398			1;