#!/usr/bin/perl use strict; use warnings; use Data::Dumper; use B::Deparse; use Template; use Getopt::Long; use CGI; use Class::MOP; my $stand_alone = 0; GetOptions("s" => \$stand_alone); if ($stand_alone) { require HTTP::Server::Simple::CGI; { package # hide me from PAUSE Class::MOP::Browser::Server; our @ISA = qw(HTTP::Server::Simple::CGI); sub handle_request { ::process_template() } } Class::MOP::Browser::Server->new()->run(); } else { print CGI::header(); process_template(); } { my $DATA; sub process_template { $DATA ||= join "" => ; Template->new->process( \$DATA, { 'get_all_metaclasses' => \&::get_all_metaclasses, 'get_metaclass_by_name' => \&::get_metaclass_by_name, 'deparse_method' => \&::deparse_method, 'deparse_item' => \&::deparse_item, } ) or warn Template->error; } } sub get_all_metaclasses { sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances() } sub get_metaclass_by_name { Class::MOP::get_metaclass_by_name(@_); } sub deparse_method { my ($method) = @_; my $deparse = B::Deparse->new("-d"); my $body = $deparse->coderef2text($method->body()); return "sub " . $method->name . ' ' . _clean_deparse_code($body); } sub deparse_item { my ($item) = @_; return $item unless ref $item; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Indent = 1; my $dumped = Dumper $item; $dumped =~ s/^\$VAR1\s=\s//; $dumped =~ s/\;$//; return _clean_deparse_code($dumped); } sub _clean_deparse_code { my @body = split /\n/ => $_[0]; my @cleaned; foreach (@body) { next if /^\s+use/; next if /^\s+BEGIN/; next if /^\s+package/; push @cleaned => $_; } return (join "\n" => @cleaned); } 1; ## This is the template file to be used __DATA__ [% USE q = CGI %] [% area = 'attributes' %] [% IF q.param('area') %] [% area = q.param('area') %] [% END %] Class::MOP Browser

Class::MOP Browser

[% IF q.param('class') && area %] [% meta = get_metaclass_by_name(q.param('class')) %] [% END %]

[% FOREACH metaclass IN get_all_metaclasses() %] [% IF q.param('class') == metaclass.name %] [% ELSE %] [% END %] [% END %]

[% metaclass.name %]

[% metaclass.name %]

[% FOREACH area_name IN [ 'attributes', 'methods', 'superclasses' ] %] [% IF q.param('class') %] [% IF area == area_name %] [% ELSE %] [% END %] [% ELSE %] [% END %] [% END %]

[% area_name %]

[% area_name %]

[% IF q.param('class') && area == 'attributes' && q.param('attr') %] [% meta = get_metaclass_by_name(q.param('class')) attr = meta.get_attribute(q.param('attr')) %] [% FOREACH aspect IN [ 'name', 'init_arg', 'reader', 'writer', 'accessor', 'predicate', 'default' ]%] [% item = attr.$aspect() %] [% END %] [% ELSIF q.param('class') && area == 'methods' && q.param('method') %] [% meta = get_metaclass_by_name(q.param('class')) method = meta.get_method(q.param('method')) %] [% FOREACH aspect IN [ 'name', 'package_name', 'fully_qualified_name' ]%] [% END %] [% END %]


[% aspect %]	[% IF item == undef %]—[% ELSE %] [% deparse_item(item) %] [% END %]
[% aspect %]	[% method.$aspect() %]
body	[% deparse_method(method) %]

[% IF area == 'methods' %] [% FOREACH method IN meta.get_method_list.sort %] [% IF q.param('method') == method %] [% ELSE %] [% END %] [% END %] [% END %] [% IF area == 'attributes' %] [% FOREACH attr IN meta.get_attribute_list.sort %] [% IF q.param('attr') == attr %] [% ELSE %] [% END %] [% END %] [% END %] [% IF area == 'superclasses' %] [% FOREACH super IN meta.superclasses.sort %] [% END %] [% END %]

[% method %]	[% method %]
[% attr %]	[% attr %]
[% super %]