/[Frey]/branches/mojo/lib/Frey/Introspect.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /branches/mojo/lib/Frey/Introspect.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 49 by dpavlin, Wed Jul 2 21:10:57 2008 UTC revision 51 by dpavlin, Thu Jul 3 19:51:18 2008 UTC
# Line 8  use Moose::Meta::Class; Line 8  use Moose::Meta::Class;
8  use Scalar::Util qw/blessed/;  use Scalar::Util qw/blessed/;
9  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
10  use File::Slurp;  use File::Slurp;
11    use List::Util;
12    
13  extends 'Frey';  extends 'Frey';
14    
# Line 17  has 'package' => ( Line 18  has 'package' => (
18          required => 1,          required => 1,
19  );  );
20    
21    has 'renderHTML' => (
22            is => 'rw',
23            isa => 'Str',
24    );
25    
26    has 'path' => (
27            is => 'rw',
28    );
29    
30    =head2 examine
31    
32      my $js = $o->examine( 'Some::Package' );
33    
34    =cut
35    
36  sub examine {  sub examine {
37          my ($self) = @_;          my ($self) = @_;
38    
39          my $package = $self->package;          my $package = $self->package;
40    
41    #intercept role application so we can accurately generate          #intercept role application so we can accurately generate
42    #method and attribute information for the parent class.          #method and attribute information for the parent class.
43    #this is fragile, but there is not better way that i am aware of          #this is fragile, but there is not better way that i am aware of
44    my $rmeta = Moose::Meta::Role->meta;          my $rmeta = Moose::Meta::Role->meta;
45    $rmeta->make_mutable if $rmeta->is_immutable;          $rmeta->make_mutable if $rmeta->is_immutable;
46    my $original_apply = $rmeta->get_method("apply")->body;          my $original_apply = $rmeta->get_method("apply")->body;
47    $rmeta->remove_method("apply");          $rmeta->remove_method("apply");
48    my @roles_to_apply;          my @roles_to_apply;
49    $rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])});          $rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])});
50    #load the package with the hacked Moose::Meta::Role          #load the package with the hacked Moose::Meta::Role
51    eval { Class::MOP::load_class($package); };          eval { Class::MOP::load_class($package); };
52    confess "Failed to load package ${package} $@" if $@;          confess "Failed to load package ${package} $@" if $@;
53    
54    #get on with analyzing the  package          #get on with analyzing the      package
55    my $meta = $package->meta;          my $meta = $package->meta;
56    my $spec = {};          my $spec = {};
57    my ($class, $is_role);          my ($class, $is_role);
58    if($package->meta->isa('Moose::Meta::Role')){          if($package->meta->isa('Moose::Meta::Role')){
59      $is_role = 1;                  $is_role = 1;
60      # we need to apply the role to a class to be able to properly introspect it                  # we need to apply the role to a class to be able to properly introspect it
61      $class = Moose::Meta::Class->create_anon_class;                  $class = Moose::Meta::Class->create_anon_class;
62      $original_apply->($meta, $class);                  $original_apply->($meta, $class);
63    } else {          } else {
64      #roles don't have superclasses ...                  #roles don't have superclasses ...
65      $class = $meta;                  $class = $meta;
66      my @superclasses = map{ $_->meta }                  my @superclasses = map{ $_->meta->name }
67        grep { $_ ne 'Moose::Object' } $meta->superclasses;                          grep { $_ ne 'Moose::Object' } $meta->superclasses;
68          warn "superclasses ",dump( @superclasses );                  warn "superclasses ",dump( @superclasses );
69    }          }
70    
71          my $out;          my $out;
72    
73          my ( $m, $c ) = split(/::/, $class->name, 2);          my ( $m, $c ) = split(/::/, $class->name, 2);
74          my $filename = "$m.$c.js";          my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';
75    
76          $out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";          $out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";
77    
78          foreach ( $class->get_attribute_list ) {          foreach ( $class->get_attribute_list ) {
79                  $out .= "\t\t\t$_: {\n";                  $out .= "\t\t\t$_: {\n";
80    
81                    my $attr = $class->get_attribute($_);
82                    my $is = $attr->_is_metadata;
83                    $out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
84                    $out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
85                    $out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
86                    $out .= "\t\t\t\tinit: \"" . $attr->init_arg . "\",\n" if $attr->init_arg;      # FIXME
87    
88                    if( defined(my $isa = $attr->_isa_metadata) ){
89                            if( blessed $isa ){
90                                    while( blessed $isa ){
91                                            $isa = $isa->name;
92                                    }
93                            }
94                            $isa =~ s/\s+\|\s+undef//gi;
95                            $out .= "\t\t\t\tisa: Moose.$isa,\n";
96                    }
97    
98    
99                  $out .= "\t\t\t},\n";                  $out .= "\t\t\t},\n";
100    
101          }          }
102    
103            $out .= "\t\t},\n\t\tmeta: Frey.HTML,
104                    classMethods: {
105                            renderHTML: function () {
106                                    return new Joose.SimpleRequest().getText(\"json?class=$c\")
107                            },\n";
108    
109          $out .= "\t\t},\n";          $out .= "\t\t},\n";
110    
111          $out .= "\t}),\n";          $out .= "\t}),\n";
112    
113            $out =~ s/,\n$/\n/;
114          $out .= "});\n";          $out .= "});\n";
115    
116          $out .= "\nconsole.log( 'loaded " . $class->name . " from $filename' );\n";          $out .= "\nconsole.log( 'loaded " . $class->name . " from $filename' );\n";
117    
118          warn $class->dump(2);          warn $class->dump(2);
119    
120          warn "get_attribute_list = ",dump( $class->get_attribute_list );          my $attr;
121  #       warn dump( map{ $class->get_attribute($_) } sort $class->get_attribute_list );          $attr->{$_}++ foreach $class->get_attribute_list;
122            my @methods = grep { ! defined($attr->{$_}) } $class->get_method_list;
123            warn "methods = ",dump( @methods );
124    
125          warn dump( $class->get_method_list );          warn "method_list = ",dump( $class->get_method_list );
126            warn dump( map{ $class->get_method($_)->name } sort $class->get_method_list );
127    
128          print $out;  #       print $out;
129          my $path = "static/blib/$filename";          my $path = "static/blib/$filename";
130          write_file( $path, $out );          write_file( $path, $out );
131          warn "# created $path\n";          warn "# created $path\n";
132            $self->path( $path );
133    
134            return $out;
135  }  }
136    
137  =head1 SEE ALSO  =head1 SEE ALSO
Legend:
Removed from v.49  
changed lines
  Added in v.51
  ViewVC Help
Powered by ViewVC 1.1.26