File Coverage

blib/lib/Circle/Configurable.pm
Criterion Covered Total %
statement 63 160 39.3
branch 4 56 7.1
condition 3 34 8.8
subroutine 19 27 70.3
pod 0 10 0.0
total 89 287 31.0


line stmt bran cond sub pod time code
1             # You may distribute under the terms of the GNU General Public License
2             #
3             # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk
4              
5             package Circle::Configurable;
6              
7 4     4   17 use strict;
  4         6  
  4         93  
8 4     4   12 use warnings;
  4         5  
  4         92  
9              
10 4     4   11 use base qw( Circle::Commandable );
  4         2  
  4         204  
11              
12 4     4   14 use Carp;
  4         4  
  4         198  
13              
14 4     4   18 use Attribute::Storage qw( get_subattr get_subattrs apply_subattrs_for_pkg find_subs_with_attr );
  4         4  
  4         21  
15 4     4   1811 use Data::Dump qw( pp );
  4         14768  
  4         709  
16             require mro;
17              
18             #############################################
19             ### Attribute handlers for setting_* subs ###
20             #############################################
21              
22             my %setting_types = (
23             str => {},
24              
25             int => {
26             check => sub { m/^\d+$/ },
27             },
28              
29             bool => {
30             parse => sub {
31             return 1 if lc $_ eq "true" or lc $_ eq "on" or $_ eq "1";
32             return 0 if lc $_ eq "false" or lc $_ eq "off" or $_ eq "0";
33             die;
34             },
35             print => sub { $_ ? "true" : "false" },
36             },
37             );
38              
39             sub Setting_description :ATTR(CODE)
40             {
41 23     23 0 2835 my $class = shift;
42 23         139 my ( $text ) = @_;
43              
44 23         51 return $text;
45 4     4   23 }
  4         5  
  4         21  
46              
47             sub Setting_type :ATTR(CODE)
48             {
49 23     23 0 3297 my $class = shift;
50 23         31 my ( $typename ) = @_;
51              
52 23 50       72 exists $setting_types{$typename} or croak "Not a recognised type name '$typename'";
53              
54 23         52 return $setting_types{$typename};
55 4     4   847 }
  4         6  
  4         12  
56              
57             sub Setting_default :ATTR(CODE)
58             {
59 4     4 0 578 my $class = shift;
60 4         9 my ( $value ) = @_;
61              
62 4         12 return $value;
63 4     4   605 }
  4         5  
  4         11  
64              
65             sub Setting_inheritable :ATTR(CODE)
66             {
67 8     8 0 904 return 1;
68 4     4   522 }
  4         7  
  4         11  
69              
70             sub APPLY_Setting
71             {
72 15     15 0 22 my $class = shift;
73 15         41 my ( $name, %args ) = @_;
74              
75 15   66     62 my $storage = $args{storage} || $name;
76              
77 4     4   549 no strict 'refs';
  4         4  
  4         625  
78 15         849 *{"${class}::setting_$name"} = apply_subattrs_for_pkg $class,
79             Setting_description => qq("\Q$args{description}\E"),
80             Setting_type => qq("\Q$args{type}\E"),
81             ( exists $args{default} ?
82             ( Setting_default => pp($args{default}) ) : () ),
83             sub {
84 0     0   0 my $self = shift;
85 0         0 my ( $newvalue ) = @_;
86              
87 0 0       0 $self->{$storage} = $newvalue if @_;
88 0         0 return $self->{$storage};
89 15 100       144 };
90             }
91              
92             sub APPLY_Inheritable_Setting
93             {
94 8     8 0 14 my $class = shift;
95 8         22 my ( $name, %args ) = @_;
96              
97 8   33     52 my $storage = $args{storage} || $name;
98              
99 8         14 my $setting = "setting_$name";
100              
101 4     4   14 no strict 'refs';
  4         6  
  4         3006  
102 8         432 *{"${class}::setting_$name"} = apply_subattrs_for_pkg $class,
103             Setting_description => qq("\Q$args{description}\E"),
104             Setting_type => qq("\Q$args{type}\E"),
105             Setting_inheritable => qq(),
106             ( exists $args{default} ?
107             ( Setting_default => pp($args{default}) ) : () ),
108             sub {
109 0     0   0 my $self = shift;
110 0         0 my ( $newvalue ) = @_;
111              
112 0 0       0 $self->{$storage} = $newvalue if @_;
113 0 0       0 return $self->{$storage} if defined $self->{$storage};
114 0 0       0 if( my $parent = $self->parent ) {
115 0         0 return $parent->$setting;
116             }
117             else {
118 0         0 return undef;
119             }
120 8 50       77 };
121 8         43 *{"${class}::_setting_${name}_inherits"} = sub {
122 0     0     my $self = shift;
123 0   0       return $self->parent && !defined $self->{$storage};
124 8         29 };
125             }
126              
127             sub _get_settings
128             {
129 0     0     my $self = shift;
130              
131 0   0       my $class = ref $self || $self;
132              
133 0           my %subs = find_subs_with_attr( mro::get_linear_isa( $class ), "Setting_description",
134             matching => qr/^setting_/
135             );
136              
137 0           my %settings;
138 0           foreach my $name ( keys %subs ) {
139 0           ( my $settingname = $name ) =~ s/^setting_//;
140 0           my $cv = $subs{$name};
141              
142 0           my $attrs = $settings{$settingname} = get_subattrs( $cv );
143 0   0       m/^Setting_(.*)$/ and $attrs->{$1} = delete $attrs->{$_} for keys %$attrs;
144             }
145              
146 0           return \%settings;
147             }
148              
149             sub command_set
150             : Command_description("Display or manipulate configuration settings")
151             : Command_arg('setting?')
152             : Command_arg('value?')
153             : Command_opt('inherit=+', desc => "Inherit value from parent")
154             : Command_opt('help=+', desc => "Display help on setting(s)")
155             : Command_opt('values=+', desc => "Display value of each setting")
156             {
157 0     0 0 0 my $self = shift;
158 0         0 my ( $setting, $newvalue, $opts, $cinv ) = @_;
159              
160 0         0 my $opt_inherit = $opts->{inherit};
161 0         0 my $opt_help = $opts->{help};
162 0         0 my $opt_values = $opts->{values};
163              
164 0 0       0 if( !defined $setting ) {
165 0         0 my $settings = $self->_get_settings;
166              
167 0 0       0 keys %$settings or $cinv->respond( "No settings exist" ), return;
168              
169 0 0       0 if( $opt_values ) {
170 0         0 my @table;
171 0         0 foreach my $settingname ( sort keys %$settings ) {
172 0         0 $setting = $settings->{$settingname};
173              
174 0         0 my $curvalue = $self->can( "setting_$settingname" )->( $self );
175 0 0       0 if( $setting->{type}->{print} ) {
176 0         0 $curvalue = $setting->{type}->{print}->( local $_ = $curvalue );
177             }
178              
179 0 0 0     0 if( $setting->{inheritable} && $self->can( "_setting_${settingname}_inherits" )->( $self ) ) {
180 0         0 $settingname .= " [I]";
181             }
182              
183 0 0       0 push @table, [
184             $settingname,
185             ( defined $curvalue ? $curvalue : "" ),
186             ];
187             }
188              
189 0         0 $self->respond_table( \@table, colsep => ": ", headings => [ "Setting", "Value" ] );
190             }
191             else {
192 0         0 my @table;
193 0         0 foreach my $settingname ( sort keys %$settings ) {
194 0         0 my $setting = $settings->{$settingname};
195              
196 0   0     0 push @table, [ $settingname, ( $setting->{Setting_description} || "[no description]" ) ];
197             }
198              
199 0         0 $cinv->respond_table( \@table, colsep => " - ", headings => [ "Setting", "Description" ] );
200             }
201              
202 0         0 return;
203             }
204              
205 0         0 my $cv = $self->can( "setting_$setting" );
206 0 0       0 if( !defined $cv ) {
207 0         0 $cinv->responderr( "No such setting $setting" );
208 0         0 return;
209             }
210              
211 0 0       0 if( $opt_help ) {
212 0   0     0 my $description = get_subattr( $cv, 'Setting_description' ) || "[no description]";
213 0         0 $cinv->respond( "$setting - $description" );
214 0         0 return;
215             }
216              
217 0         0 my $type = get_subattr( $cv, 'Setting_type' );
218              
219 0         0 my $curvalue;
220 0 0 0     0 if( defined $newvalue or $opt_inherit ) {
221 0 0 0     0 if( !$opt_inherit and $type->{check} ) {
222 0         0 local $_ = $newvalue;
223 0 0       0 $type->{check}->( $newvalue ) or
224             $cinv->responderr( "'$newvalue' is not a valid value for $setting" ), return;
225             }
226              
227 0 0 0     0 if( !$opt_inherit and $type->{parse} ) {
228 0         0 local $_ = $newvalue;
229 0 0       0 eval { $newvalue = $type->{parse}->( $newvalue ); 1 } or
  0         0  
  0         0  
230             $cinv->responderr( "'$newvalue' is not a valid value for $setting" ), return;
231             }
232              
233 0 0       0 undef $newvalue if $opt_inherit;
234 0         0 $curvalue = $cv->( $self, $newvalue );
235             }
236             else {
237 0         0 $curvalue = $cv->( $self );
238             }
239              
240 0 0       0 if( $type->{print} ) {
241 0         0 local $_ = $curvalue;
242 0         0 $curvalue = $type->{print}->( local $_ = $curvalue );
243             }
244              
245 0 0       0 if( defined $curvalue ) {
246 0         0 $cinv->respond( "$setting: $curvalue" );
247             }
248             else {
249 0         0 $cinv->respond( "$setting is not set" );
250             }
251              
252 0         0 return;
253 4     4   20 }
  4         4  
  4         19  
254              
255             sub get_configuration
256             {
257 0     0 0   my $self = shift;
258              
259 0           my $ynode = YAML::Node->new({});
260 0           $self->store_configuration( $ynode );
261              
262 0           return $ynode;
263             }
264              
265             sub load_configuration
266             {
267 0     0 0   my $self = shift;
268 0           my ( $ynode ) = @_;
269              
270 0           foreach my $setting ( keys %{ $self->_get_settings } ) {
  0            
271 0 0         my $cv = $self->can( "setting_$setting" ) or croak "$self has no setting $setting";
272 0           my $value = $ynode->{$setting};
273 0 0 0       if( !defined $value and
274             defined( my $default = get_subattr( $cv, "Setting_default" ) ) ) {
275 0           $value = $default;
276             }
277 0 0         $cv->( $self, $value ) if defined $value;
278             }
279             }
280              
281             sub store_configuration
282             {
283 0     0 0   my $self = shift;
284 0           my ( $ynode ) = @_;
285              
286 0           foreach my $setting ( keys %{ $self->_get_settings } ) {
  0            
287 0 0         my $cv = $self->can( "setting_$setting" ) or croak "$self has no setting $setting";
288 0           my $value = $cv->( $self );
289 0 0         $ynode->{$setting} = $value if defined $value;
290             }
291             }
292              
293             0x55AA;