File Coverage

blib/lib/Refine.pm
Criterion Covered Total %
statement 33 33 100.0
branch 1 2 50.0
condition n/a
subroutine 11 11 100.0
pod n/a
total 45 46 97.8


line stmt bran cond sub pod time code
1             package Refine;
2              
3             =head1 NAME
4              
5             Refine - Refine an instance with new methods
6              
7             =head1 VERSION
8              
9             0.01
10              
11             =head1 DESCRIPTION
12              
13             L is a module that export C<$_refine> which can be used to add
14             methods object instances. Each C<$_refine> call on the object will create a
15             new class with the new refined methods and rebless the instance into that
16             class, which keeps the original class as it was.
17              
18             This is an EXPERIMENTAL release. The class generator might change in future releases.
19              
20             =head1 SYNOPSIS
21              
22             use Refine;
23             use Data::Dumper ();
24              
25             my $obj = Some::Class->new;
26              
27             # add the dump() method to the $obj instance
28             $obj->$_refine(
29             dump => sub { Data::Dumper->new([$_[0])->Terse(1)->SortKeys(1)->Dump },
30             );
31              
32             =head1 OPTIONAL MODULES
33              
34             =over 4
35              
36             =item * Sub::Name
37              
38             If you have L installed, the methods will have proper names,
39             instead of "__ANON__". This will make stacktraces easier to read.
40              
41             =back
42              
43             =cut
44              
45 3     3   92684 use strict;
  3         8  
  3         107  
46 3     3   14 use warnings;
  3         6  
  3         85  
47 3     3   14 use Carp ();
  3         4  
  3         69  
48 3 50   3   16 use constant SUB_NAME => eval 'require Sub::Name;1' ? 1 : 0;
  3         5  
  3         171  
49 3     3   397 use base 'Exporter';
  3         5  
  3         1647  
50              
51             our $VERSION = '0.01';
52             our @EXPORT = '$_refine';
53              
54             my %PRIVATE2PUBLIC;
55              
56             our $_refine = sub {
57             my ($self, %patch) = @_;
58             my $class = ref $self;
59             my $private_name = join ':', $class, map { $_, $patch{$_} } sort keys %patch;
60             my $refined_class = $PRIVATE2PUBLIC{$private_name};
61              
62             unless ($class) {
63             Carp::confess("Can only add methods to instances, not $self");
64             }
65              
66             unless ($refined_class) {
67             my $base_class = $class;
68              
69             if ($class =~ s!::WITH::(.*)!!) {
70             $patch{$_} ||= '' for grep { !/^_\d+$/ } split /::/, $1;
71             }
72              
73             my $i = 0;
74             my $public_name = substr +("$class\::WITH::" .join '::', sort keys %patch), 0, 180;
75              
76             do {
77             $refined_class = "$public_name\::_$i";
78             $i++;
79             } while ($refined_class->can('new'));
80             $PRIVATE2PUBLIC{$private_name} = $refined_class;
81 3     3   25 eval "package $refined_class;use base '$base_class';1" or Carp::confess("Failed to refine $class: $@");
  3     2   6  
  3     2   285  
  2     2   13  
  2         3  
  2         646  
  2         13  
  2         30  
  2         522  
  2         12  
  2         4  
  2         555  
82              
83             for my $n (grep { $patch{$_} } keys %patch) {
84 3     3   19 no strict 'refs';
  3         6  
  3         528  
85             *{"$refined_class\::$n"} = SUB_NAME ? Sub::Name::subname("$refined_class\::$n", $patch{$n}) : $patch{$n};
86             }
87             }
88              
89 3     3   279 no strict 'refs';
  3         6  
  3         262  
90             bless $self, $refined_class;
91             $self;
92             };
93              
94             =head1 COPYRIGHT AND LICENSE
95              
96             Copyright (C) 2014, Jan Henning Thorsen
97              
98             This program is free software, you can redistribute it and/or modify it under
99             the terms of the Artistic License version 2.0.
100              
101             =head1 AUTHOR
102              
103             Jan Henning Thorsen - C
104              
105             =cut
106              
107             1;