[gitmo/Moose.git] / eg / class_browser.pl

#!/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 "" => <DATA>;
        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 %]

<html>
<head>
<title>Class::MOP Browser</title>
<style type='text/css'>

body {
    font-family: arial;
}

td { font-size: 12px; }
b  { font-size: 12px; }

pre {
    font-family: courier;
    font-size:   12px;
    width:       330px;
    padding:     10px;
    overflow:    auto;
    border:      1px dotted green;
}

A {
    font-family: arial;
    font-size:   12px;
    color: black;
    text-decoration: none;
}

A:hover {
    text-decoration: underline;
}

td.lightblue  {
    background-color: #99BBFF;
    border-right:  1px solid #336699;
    border-bottom: 1px solid #336699;
    border-top:    1px solid #BBDDFF;
    border-left:   1px solid #BBDDFF;
}

td.grey       {
    background-color: #CCCCCC;
    border-right:  1px solid #888888;
    border-bottom: 1px solid #888888;
    border-top:    1px solid #DDDDDD;
    border-left:   1px solid #DDDDDD;
}

td.manila     {
    background-color: #FFDD99;
    border-right:  2px solid #CC9933;
    border-bottom: 2px solid #CC9933;
    border-top:    2px solid #FFFFBB;
    border-left:   2px solid #FFFFBB;
}

td.darkgreen  {
    background-color: #33CC33;
    border-right:  1px solid #009900;
    border-bottom: 1px solid #009900;
    color: #CCFFCC;
}

td.lightgreen {
    background-color: #AAFFAA;
    border-right:  1px solid #33FF33;
    border-bottom: 1px solid #33FF33;
}

</style>
</head>
<body>
<h1>Class::MOP Browser</h1>
<table bgcolor='#CCCCCC' cellpadding='0' cellspacing='0' border='0' align='center' height='400'>
<tr valign='top'>

<td rowspan='2' width='200'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
    [% FOREACH metaclass IN get_all_metaclasses() %]
        <tr>
        [% IF q.param('class') == metaclass.name %]
            <td class='lightblue'><b>[% metaclass.name %]</b></td>
        [% ELSE %]
            <td class='grey'><a href='?class=[% metaclass.name %]'>[% metaclass.name %]</a></td>
        [% END %]
        </tr>
    [% END %]
    </table></td>
<td height='10' width='250'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
    <tr align='center'>
    [% FOREACH area_name IN [ 'attributes', 'methods', 'superclasses' ] %]
        [% IF q.param('class') %]
            [% IF area == area_name %]
                <td class='manila'><b>[% area_name %]</b></td>
            [% ELSE %]
                <td class='lightblue'><a href='?class=[% q.param('class') %]&area=[% area_name %]'>[% area_name %]</a></td>
            [% END %]
        [% ELSE %]
            <td class='lightblue' style="color: #336699;">[% area_name %]</td>
        [% END %]
    [% END %]
    </tr>
    </table></td>

<td valign='top' rowspan='2' class='lightgreen' width='450'>
    <table cellspacing='0' cellpadding='3' border='0'>
    <tr>
    <td class='darkgreen' width='100'></td>
    <td class='darkgreen' width='350'></td>
    </tr>
    [% 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() %]
            <tr>
            <td class='darkgreen' align='right' valign='top'>[% aspect %]</td>
            <td class='lightgreen'>[% IF item == undef %]&mdash;[% ELSE %]<pre>[% deparse_item(item) %]</pre>[% END %]</td>
            </tr>
        [% 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' ]%]
            <tr>
            <td class='darkgreen' align='right' valign='top'>[% aspect %]</td>
            <td class='lightgreen'>[% method.$aspect() %]</td>
            </tr>
        [% END %]
            <tr>
            <td class='darkgreen' align='right' valign='top'>body</td>
            <td class='lightgreen'><pre>[% deparse_method(method) %]</pre></td>
            </tr>

    [% END %]
    </table></td>

</tr>
<tr>

[% IF q.param('class') && area %]

[% meta = get_metaclass_by_name(q.param('class')) %]

<td class='lightblue' valign='top'><div style='height: 100%; overflow: auto;'><table cellspacing='0' cellpadding='5' border='0' width='100%'>

    [% IF area == 'methods' %]
        [% FOREACH method IN meta.get_method_list.sort %]
            <tr>
                [% IF q.param('method') == method %]
                    <td class='darkgreen'><b>[% method %]</b></td>
                [% ELSE %]
                    <td class='manila'><a href='?class=[% q.param('class') %]&area=[% q.param('area') %]&method=[% method %]'>[% method %]</a></td>
                [% END %]
            </tr>
        [% END %]
    [% END %]
    [% IF area == 'attributes' %]
        [% FOREACH attr IN meta.get_attribute_list.sort %]
            <tr>
                [% IF q.param('attr') == attr %]
                    <td class='darkgreen'><b>[% attr %]</b></td>
                [% ELSE %]
                    <td class='manila'><a href='?class=[% q.param('class') %]&area=[% q.param('area') %]&attr=[% attr %]'>[% attr %]</a></td>
                [% END %]
            </tr>
        [% END %]
    [% END %]
    [% IF area == 'superclasses' %]
        [% FOREACH super IN meta.superclasses.sort %]
            <tr>
                <td class='manila'><a href='?class=[% super %]'>[% super %]</a></td>
            </tr>
        [% END %]
    [% END %]
    </table></div></td>
[% END %]

</tr>
</table>
</body>
</html>
Commit	Line	Data
38bf2a25	1	#!/usr/bin/perl
	2
	3	use strict;
	4	use warnings;
	5
	6	use Data::Dumper;
	7	use B::Deparse;
	8	use Template;
	9	use Getopt::Long;
	10	use CGI;
	11
	12	use Class::MOP;
	13
	14	my $stand_alone = 0;
	15	GetOptions("s" => \$stand_alone);
	16
	17	if ($stand_alone) {
	18	require HTTP::Server::Simple::CGI;
	19	{
	20	package # hide me from PAUSE
	21	Class::MOP::Browser::Server;
	22	our @ISA = qw(HTTP::Server::Simple::CGI);
	23	sub handle_request { ::process_template() }
064a13a3	24	}
064a13a3	25	Class::MOP::Browser::Server->new()->run();
38bf2a25	26	}
	27	else {
	28	print CGI::header();
	29	process_template();
	30	}
	31
	32	{
	33	my $DATA;
	34	sub process_template {
	35	$DATA \|\|= join "" => <DATA>;
	36	Template->new->process(
	37	\$DATA,
	38	{
	39	'get_all_metaclasses' => \&::get_all_metaclasses,
	40	'get_metaclass_by_name' => \&::get_metaclass_by_name,
	41	'deparse_method' => \&::deparse_method,
	42	'deparse_item' => \&::deparse_item,
	43	}
064a13a3	44	) or warn Template->error;
38bf2a25	45	}
	46	}
	47
064a13a3	48	sub get_all_metaclasses {
064a13a3	49	sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances()
38bf2a25	50	}
064a13a3	51
	52	sub get_metaclass_by_name {
	53	Class::MOP::get_metaclass_by_name(@_);
38bf2a25	54	}
	55
	56	sub deparse_method {
	57	my ($method) = @_;
	58	my $deparse = B::Deparse->new("-d");
	59	my $body = $deparse->coderef2text($method->body());
	60	return "sub " . $method->name . ' ' . _clean_deparse_code($body);
	61	}
	62
	63	sub deparse_item {
	64	my ($item) = @_;
	65	return $item unless ref $item;
	66	local $Data::Dumper::Deparse = 1;
	67	local $Data::Dumper::Indent = 1;
064a13a3	68	my $dumped = Dumper $item;
38bf2a25	69	$dumped =~ s/^\$VAR1\s=\s//;
064a13a3	70	$dumped =~ s/\;$//;
38bf2a25	71	return _clean_deparse_code($dumped);
	72	}
	73
	74	sub _clean_deparse_code {
	75	my @body = split /\n/ => $_[0];
	76	my @cleaned;
	77	foreach (@body) {
	78	next if /^\s+use/;
064a13a3	79	next if /^\s+BEGIN/;
064a13a3	80	next if /^\s+package/;
38bf2a25	81	push @cleaned => $_;
064a13a3	82	}
064a13a3	83	return (join "\n" => @cleaned);
38bf2a25	84	}
	85
	86	1;
	87
	88	## This is the template file to be used
	89
	90	__DATA__
	91	[% USE q = CGI %]
	92
	93	[% area = 'attributes' %]
	94	[% IF q.param('area') %]
	95	[% area = q.param('area') %]
	96	[% END %]
	97
	98	<html>
	99	<head>
	100	<title>Class::MOP Browser</title>
	101	<style type='text/css'>
	102
	103	body {
	104	font-family: arial;
	105	}
	106
	107	td { font-size: 12px; }
	108	b { font-size: 12px; }
	109
	110	pre {
	111	font-family: courier;
	112	font-size: 12px;
	113	width: 330px;
	114	padding: 10px;
	115	overflow: auto;
	116	border: 1px dotted green;
	117	}
	118
064a13a3	119	A {
38bf2a25	120	font-family: arial;
064a13a3	121	font-size: 12px;
38bf2a25	122	color: black;
	123	text-decoration: none;
	124	}
	125
	126	A:hover {
064a13a3	127	text-decoration: underline;
38bf2a25	128	}
064a13a3	129
	130	td.lightblue {
	131	background-color: #99BBFF;
	132	border-right: 1px solid #336699;
	133	border-bottom: 1px solid #336699;
	134	border-top: 1px solid #BBDDFF;
	135	border-left: 1px solid #BBDDFF;
38bf2a25	136	}
38bf2a25	137
064a13a3	138	td.grey {
	139	background-color: #CCCCCC;
	140	border-right: 1px solid #888888;
	141	border-bottom: 1px solid #888888;
	142	border-top: 1px solid #DDDDDD;
	143	border-left: 1px solid #DDDDDD;
38bf2a25	144	}
38bf2a25	145
064a13a3	146	td.manila {
38bf2a25	147	background-color: #FFDD99;
064a13a3	148	border-right: 2px solid #CC9933;
	149	border-bottom: 2px solid #CC9933;
	150	border-top: 2px solid #FFFFBB;
	151	border-left: 2px solid #FFFFBB;
38bf2a25	152	}
38bf2a25	153
064a13a3	154	td.darkgreen {
	155	background-color: #33CC33;
	156	border-right: 1px solid #009900;
	157	border-bottom: 1px solid #009900;
	158	color: #CCFFCC;
38bf2a25	159	}
38bf2a25	160
064a13a3	161	td.lightgreen {
	162	background-color: #AAFFAA;
	163	border-right: 1px solid #33FF33;
	164	border-bottom: 1px solid #33FF33;
38bf2a25	165	}
	166
	167	</style>
	168	</head>
	169	<body>
	170	<h1>Class::MOP Browser</h1>
	171	<table bgcolor='#CCCCCC' cellpadding='0' cellspacing='0' border='0' align='center' height='400'>
	172	<tr valign='top'>
064a13a3	173
38bf2a25	174	<td rowspan='2' width='200'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
	175	[% FOREACH metaclass IN get_all_metaclasses() %]
	176	<tr>
	177	[% IF q.param('class') == metaclass.name %]
	178	<td class='lightblue'><b>[% metaclass.name %]</b></td>
	179	[% ELSE %]
	180	<td class='grey'><a href='?class=[% metaclass.name %]'>[% metaclass.name %]</a></td>
	181	[% END %]
	182	</tr>
	183	[% END %]
	184	</table></td>
	185	<td height='10' width='250'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
064a13a3	186	<tr align='center'>
38bf2a25	187	[% FOREACH area_name IN [ 'attributes', 'methods', 'superclasses' ] %]
38bf2a25	188	[% IF q.param('class') %]
064a13a3	189	[% IF area == area_name %]
38bf2a25	190	<td class='manila'><b>[% area_name %]</b></td>
	191	[% ELSE %]
	192	<td class='lightblue'><a href='?class=[% q.param('class') %]&area=[% area_name %]'>[% area_name %]</a></td>
	193	[% END %]
	194	[% ELSE %]
	195	<td class='lightblue' style="color: #336699;">[% area_name %]</td>
	196	[% END %]
	197	[% END %]
	198	</tr>
	199	</table></td>
	200
	201	<td valign='top' rowspan='2' class='lightgreen' width='450'>
	202	<table cellspacing='0' cellpadding='3' border='0'>
064a13a3	203	<tr>
	204	<td class='darkgreen' width='100'></td>
	205	<td class='darkgreen' width='350'></td>
	206	</tr>
38bf2a25	207	[% IF q.param('class') && area == 'attributes' && q.param('attr') %]
38bf2a25	208
064a13a3	209	[%
38bf2a25	210	meta = get_metaclass_by_name(q.param('class'))
	211	attr = meta.get_attribute(q.param('attr'))
	212	%]
	213
	214	[% FOREACH aspect IN [ 'name', 'init_arg', 'reader', 'writer', 'accessor', 'predicate', 'default' ]%]
	215	[% item = attr.$aspect() %]
	216	<tr>
	217	<td class='darkgreen' align='right' valign='top'>[% aspect %]</td>
	218	<td class='lightgreen'>[% IF item == undef %]—[% ELSE %]<pre>[% deparse_item(item) %]</pre>[% END %]</td>
	219	</tr>
	220	[% END %]
	221
	222	[% ELSIF q.param('class') && area == 'methods' && q.param('method') %]
	223
064a13a3	224	[%
38bf2a25	225	meta = get_metaclass_by_name(q.param('class'))
	226	method = meta.get_method(q.param('method'))
	227	%]
	228
	229	[% FOREACH aspect IN [ 'name', 'package_name', 'fully_qualified_name' ]%]
	230	<tr>
	231	<td class='darkgreen' align='right' valign='top'>[% aspect %]</td>
	232	<td class='lightgreen'>[% method.$aspect() %]</td>
	233	</tr>
	234	[% END %]
	235	<tr>
	236	<td class='darkgreen' align='right' valign='top'>body</td>
	237	<td class='lightgreen'><pre>[% deparse_method(method) %]</pre></td>
064a13a3	238	</tr>
38bf2a25	239
	240	[% END %]
	241	</table></td>
	242
	243	</tr>
	244	<tr>
	245
	246	[% IF q.param('class') && area %]
	247
	248	[% meta = get_metaclass_by_name(q.param('class')) %]
	249
	250	<td class='lightblue' valign='top'><div style='height: 100%; overflow: auto;'><table cellspacing='0' cellpadding='5' border='0' width='100%'>
	251
	252	[% IF area == 'methods' %]
	253	[% FOREACH method IN meta.get_method_list.sort %]
	254	<tr>
	255	[% IF q.param('method') == method %]
064a13a3	256	<td class='darkgreen'><b>[% method %]</b></td>
38bf2a25	257	[% ELSE %]
	258	<td class='manila'><a href='?class=[% q.param('class') %]&area=[% q.param('area') %]&method=[% method %]'>[% method %]</a></td>
	259	[% END %]
	260	</tr>
064a13a3	261	[% END %]
38bf2a25	262	[% END %]
	263	[% IF area == 'attributes' %]
	264	[% FOREACH attr IN meta.get_attribute_list.sort %]
	265	<tr>
	266	[% IF q.param('attr') == attr %]
064a13a3	267	<td class='darkgreen'><b>[% attr %]</b></td>
38bf2a25	268	[% ELSE %]
	269	<td class='manila'><a href='?class=[% q.param('class') %]&area=[% q.param('area') %]&attr=[% attr %]'>[% attr %]</a></td>
	270	[% END %]
	271	</tr>
064a13a3	272	[% END %]
064a13a3	273	[% END %]
38bf2a25	274	[% IF area == 'superclasses' %]
	275	[% FOREACH super IN meta.superclasses.sort %]
	276	<tr>
	277	<td class='manila'><a href='?class=[% super %]'>[% super %]</a></td>
	278	</tr>
064a13a3	279	[% END %]
064a13a3	280	[% END %]
38bf2a25	281	</table></div></td>
	282	[% END %]
	283
	284	</tr>
	285	</table>
	286	</body>
	287	</html>
	288