scripts/class_browser.pl

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