Permalink
Browse files

Merge remote-tracking branch 'DHowett/master'

  • Loading branch information...
2 parents 563a9cb + 133cab4 commit f6a2cdf3afe15cb81763c79dfd12221fa70e5a80 @rpetrich committed Mar 3, 2012
Showing with 193 additions and 102 deletions.
  1. +8 −0 bin/lib/Logos/Generator.pm
  2. +26 −3 bin/lib/Logos/Generator/Thunk.pm
  3. +50 −4 bin/lib/Logos/Patch.pm
  4. +27 −0 bin/lib/Logos/Patch/Source/Generator.pm
  5. +82 −95 bin/logos.pl
@@ -6,14 +6,21 @@ use Module::Load::Conditional qw(can_load);
$Module::Load::Conditional::VERBOSE = 1;
our $GeneratorPackage = "";
+my %cache;
+
sub for {
my $object = shift;
my $dequalified = undef;
+ my $cachekey;
if(defined $object) {
+ $cachekey = $object;
my $class = blessed($object);
($dequalified = $class) =~ s/.*::// if defined $class
}
+ $cachekey = "-" if !$cachekey;
$dequalified .= "Generator" if !defined $dequalified;
+ return $cache{$cachekey} if $cache{$cachekey};
+
my $qualified = $GeneratorPackage."::".$dequalified;
my $fallback = "Logos::Generator::Base::".$dequalified;
@@ -22,6 +29,7 @@ sub for {
can_load(modules=>{$fallback=>undef},verbose=>1) if $shouldFallBack;
my $thunk = Logos::Generator::Thunk->for(($shouldFallBack ? $fallback : $qualified), $object);
+ $cache{$cachekey} = $thunk;
return $thunk;
}
@@ -3,19 +3,42 @@ use strict;
our $AUTOLOAD;
+my %subrefCache;
+
sub AUTOLOAD {
my $self = shift;
my $method = $AUTOLOAD;
+ return if $method eq "DESTROY";
+
$method =~ s/.*:://;
my $fullyQualified = $self->{PACKAGE}."::".$method;
+ my $subref = $subrefCache{$fullyQualified};
+
+ $subref = $self->can($method) if !$subref;
+
unshift @_, $self->{OBJECT} if $self->{OBJECT};
- unshift @_, $self->{PACKAGE};
- goto &{$self->{PACKAGE}->can($method)};
+ goto &$subref;
+}
+
+sub can {
+ my $self = shift;
+ my $method = shift;
+ my $subref = $self->SUPER::can($method);
+ return $subref if $subref;
+
+ $method =~ s/.*:://;
+ my $fullyQualified = $self->{PACKAGE}."::".$method;
+ return $subrefCache{$fullyQualified} if $subrefCache{$fullyQualified};
+
+ $subref = sub {unshift @_, $self->{PACKAGE}; goto &{$self->{PACKAGE}->can($method)}};
+ $subrefCache{$fullyQualified} = $subref;
+
+ return $subref;
}
sub DESTROY {
my $self = shift;
- goto &{$self->SUPER::DESTROY};
+ $self->SUPER::destroy();
}
sub for {
View
@@ -7,7 +7,8 @@ sub new {
my $self = {};
$self->{LINE} = -1;
$self->{RANGE} = [];
- $self->{SUBREF} = undef;
+ $self->{SOURCE} = undef;
+ $self->{SQUASH} = 0;
bless($self, $class);
return $self;
}
@@ -39,14 +40,59 @@ sub end {
return $self->{RANGE}[1];
}
-sub subref {
+sub source {
my $self = shift;
- if(@_) { $self->{SUBREF} = shift; }
- return $self->{SUBREF};
+ if(@_) { $self->{SOURCE} = shift; }
+ return $self->{SOURCE};
+}
+
+sub squash {
+ my $self = shift;
+ if(@_) { $self->{SQUASH} = shift; }
+ return $self->{SQUASH};
}
##### #
# END #
# #####
+sub evalSource {
+ my $self = shift;
+ my $source = shift;
+ my $sourceref = ref($source);
+ my @lines;
+ if($sourceref) {
+ if($sourceref eq "ARRAY") {
+ for(@$source) {
+ splice(@lines, scalar @lines, 0, $self->evalSource($_));
+ }
+ } else {
+ push(@lines, $source->eval());
+ }
+ } else {
+ push(@lines, $source);
+ }
+ return @lines;
+}
+
+sub apply {
+ my $self = shift;
+ my $lref = shift;
+ my $line = $self->{LINE};
+ my ($start, $end) = @{$self->{RANGE}};
+ my $source = $self->{SOURCE};
+ my @lines = $self->evalSource($source);
+ if(!defined $start) {
+ push(@lines, ::generateLineDirectiveForPhysicalLine($line));
+ if($self->{SQUASH}) {
+ push(@$lref, join('', @lines));
+ } else {
+ splice(@$lref, $line, 0, @lines);
+ }
+ } else {
+ substr($lref->[$line], $start, $end-$start) = join('', @lines);
+ }
+ return;
+}
+
1;
@@ -0,0 +1,27 @@
+package Logos::Patch::Source::Generator;
+use strict;
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self->{OBJECT} = shift;
+ $self->{METHOD} = shift;
+ my @args = @_;
+ $self->{ARGS} = \@args;
+ bless($self, $class);
+ return $self;
+}
+
+sub eval {
+ #no strict 'refs';
+ my $self = shift;
+ my @args = @{$self->{ARGS}};
+ splice(@args, 0, 0, $self->{OBJECT}) if $self->{OBJECT};
+ return Logos::Generator::for($self->{OBJECT})->can($self->{METHOD})->(@args);
+ #my $thunk = Logos::Generator::for($self->{OBJECT})->can($self->{METHOD})-(>${$self->{ARGS}});;
+ #my $mname = $self->{METHOD};
+ #return $thunk->$mname(@{$self->{ARGS}});
+}
+
+1;
Oops, something went wrong.

0 comments on commit f6a2cdf

Please sign in to comment.