[gitmo/Class-MOP.git] / scripts / 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
085f1c71	1	#!/usr/bin/perl
	2
	3	use strict;
	4	use warnings;
	5
085f1c71	6	use Data::Dumper;
	7	use B::Deparse;
	8	use Template;
	9	use Getopt::Long;
dbc791f9	10	use CGI;
085f1c71	11
dbc791f9	12	use Class::MOP;
085f1c71	13
085f1c71	14	my $stand_alone = 0;
dbc791f9	15	GetOptions("s" => \$stand_alone);
085f1c71	16
085f1c71	17	if ($stand_alone) {
dbc791f9	18	require HTTP::Server::Simple::CGI;
085f1c71	19	{
dbc791f9	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() }
085f1c71	24	}
dbc791f9	25	Class::MOP::Browser::Server->new()->run();
085f1c71	26	}
085f1c71	27	else {
085f1c71	28	print CGI::header();
dbc791f9	29	process_template();
085f1c71	30	}
085f1c71	31
dbc791f9	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	}
	44	) or warn Template->error;
	45	}
	46	}
085f1c71	47
	48	sub get_all_metaclasses {
	49	sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances()
	50	}
	51
	52	sub get_metaclass_by_name {
	53	Class::MOP::get_metaclass_by_name(@_);
	54	}
	55
	56	sub deparse_method {
	57	my ($method) = @_;
085f1c71	58	my $deparse = B::Deparse->new("-d");
085f1c71	59	my $body = $deparse->coderef2text($method->body());
dbc791f9	60	return "sub " . $method->name . ' ' . _clean_deparse_code($body);
085f1c71	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;
	68	my $dumped = Dumper $item;
	69	$dumped =~ s/^\$VAR1\s=\s//;
	70	$dumped =~ s/\;$//;
dbc791f9	71	return _clean_deparse_code($dumped);
dbc791f9	72	}
085f1c71	73
dbc791f9	74	sub _clean_deparse_code {
dbc791f9	75	my @body = split /\n/ => $_[0];
085f1c71	76	my @cleaned;
085f1c71	77	foreach (@body) {
	78	next if /^\s+use/;
	79	next if /^\s+BEGIN/;
	80	next if /^\s+package/;
	81	push @cleaned => $_;
dbc791f9	82	}
dbc791f9	83	return (join "\n" => @cleaned);
085f1c71	84	}
	85
	86	1;
	87
	88	## This is the template file to be used
	89
	90	__DATA__
	91	[% USE q = CGI %]
dbc791f9	92
085f1c71	93	[% area = 'attributes' %]
	94	[% IF q.param('area') %]
	95	[% area = q.param('area') %]
	96	[% END %]
dbc791f9	97
085f1c71	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
	119	A {
	120	font-family: arial;
	121	font-size: 12px;
	122	color: black;
	123	text-decoration: none;
	124	}
	125
	126	A:hover {
	127	text-decoration: underline;
	128	}
	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;
	136	}
	137
	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;
	144	}
	145
	146	td.manila {
	147	background-color: #FFDD99;
	148	border-right: 2px solid #CC9933;
	149	border-bottom: 2px solid #CC9933;
	150	border-top: 2px solid #FFFFBB;
	151	border-left: 2px solid #FFFFBB;
	152	}
	153
	154	td.darkgreen {
	155	background-color: #33CC33;
	156	border-right: 1px solid #009900;
	157	border-bottom: 1px solid #009900;
	158	color: #CCFFCC;
	159	}
	160
	161	td.lightgreen {
162	background-color: #AAFFAA;
163	border-right: 1px solid #33FF33;
164	border-bottom: 1px solid #33FF33;
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'>
173
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 %]
dbc791f9	178	<td class='lightblue'><b>[% metaclass.name %]</b></td>
085f1c71	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%'>
	186	<tr align='center'>
	187	[% FOREACH area_name IN [ 'attributes', 'methods', 'superclasses' ] %]
	188	[% IF q.param('class') %]
	189	[% IF area == area_name %]
	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'>
	203	<tr>
	204	<td class='darkgreen' width='100'></td>
	205	<td class='darkgreen' width='350'></td>
	206	</tr>
	207	[% IF q.param('class') && area == 'attributes' && q.param('attr') %]
	208
	209	[%
	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
	224	[%
	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>
	238	</tr>
	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 %]
256	<td class='darkgreen'><b>[% method %]</b></td>
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>
261	[% END %]
262	[% END %]
263	[% IF area == 'attributes' %]
264	[% FOREACH attr IN meta.get_attribute_list.sort %]
265	<tr>
266	[% IF q.param('attr') == attr %]
267	<td class='darkgreen'><b>[% attr %]</b></td>
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>
272	[% END %]
273	[% END %]
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>
279	[% END %]
280	[% END %]
281	</table></div></td>
282	[% END %]
283
284	</tr>
285	</table>
286	</body>
287	</html>
288