Commit | Line | Data |
bb4e9162 |
1 | package Module::Build::Notes; |
2 | |
3 | # A class for persistent hashes |
4 | |
5 | use strict; |
7a827510 |
6 | use vars qw($VERSION); |
7 | $VERSION = '0.2808_01'; |
8 | $VERSION = eval $VERSION; |
bb4e9162 |
9 | use Data::Dumper; |
10 | use IO::File; |
7a827510 |
11 | use Module::Build::Dumper; |
bb4e9162 |
12 | |
bb4e9162 |
13 | sub new { |
14 | my ($class, %args) = @_; |
15 | my $file = delete $args{file} or die "Missing required parameter 'file' to new()"; |
16 | my $self = bless { |
17 | disk => {}, |
18 | new => {}, |
19 | file => $file, |
20 | %args, |
21 | }, $class; |
22 | } |
23 | |
24 | sub restore { |
25 | my $self = shift; |
26 | |
27 | my $fh = IO::File->new("< $self->{file}") or die "Can't read $self->{file}: $!"; |
28 | $self->{disk} = eval do {local $/; <$fh>}; |
29 | die $@ if $@; |
30 | $self->{new} = {}; |
31 | } |
32 | |
33 | sub access { |
34 | my $self = shift; |
35 | return $self->read() unless @_; |
36 | |
37 | my $key = shift; |
38 | return $self->read($key) unless @_; |
39 | |
40 | my $value = shift; |
41 | $self->write({ $key => $value }); |
42 | return $self->read($key); |
43 | } |
44 | |
45 | sub has_data { |
46 | my $self = shift; |
47 | return keys %{$self->read()} > 0; |
48 | } |
49 | |
50 | sub exists { |
51 | my ($self, $key) = @_; |
52 | return exists($self->{new}{$key}) || exists($self->{disk}{$key}); |
53 | } |
54 | |
55 | sub read { |
56 | my $self = shift; |
57 | |
58 | if (@_) { |
59 | # Return 1 key as a scalar |
60 | my $key = shift; |
61 | return $self->{new}{$key} if exists $self->{new}{$key}; |
62 | return $self->{disk}{$key}; |
63 | } |
64 | |
65 | # Return all data |
66 | my $out = (keys %{$self->{new}} |
67 | ? {%{$self->{disk}}, %{$self->{new}}} |
68 | : $self->{disk}); |
69 | return wantarray ? %$out : $out; |
70 | } |
71 | |
72 | sub _same { |
73 | my ($self, $x, $y) = @_; |
74 | return 1 if !defined($x) and !defined($y); |
75 | return 0 if !defined($x) or !defined($y); |
76 | return $x eq $y; |
77 | } |
78 | |
79 | sub write { |
80 | my ($self, $href) = @_; |
81 | $href ||= {}; |
82 | |
83 | @{$self->{new}}{ keys %$href } = values %$href; # Merge |
84 | |
85 | # Do some optimization to avoid unnecessary writes |
86 | foreach my $key (keys %{ $self->{new} }) { |
87 | next if ref $self->{new}{$key}; |
88 | next if ref $self->{disk}{$key} or !exists $self->{disk}{$key}; |
89 | delete $self->{new}{$key} if $self->_same($self->{new}{$key}, $self->{disk}{$key}); |
90 | } |
91 | |
92 | if (my $file = $self->{file}) { |
93 | my ($vol, $dir, $base) = File::Spec->splitpath($file); |
94 | $dir = File::Spec->catpath($vol, $dir, ''); |
95 | return unless -e $dir && -d $dir; # The user needs to arrange for this |
96 | |
97 | return if -e $file and !keys %{ $self->{new} }; # Nothing to do |
98 | |
99 | @{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}}; # Merge |
100 | $self->_dump($file, $self->{disk}); |
101 | |
102 | $self->{new} = {}; |
103 | } |
104 | return $self->read; |
105 | } |
106 | |
107 | sub _dump { |
108 | my ($self, $file, $data) = @_; |
109 | |
110 | my $fh = IO::File->new("> $file") or die "Can't create '$file': $!"; |
7a827510 |
111 | print {$fh} Module::Build::Dumper->_data_dump($data); |
bb4e9162 |
112 | } |
113 | |
114 | sub write_config_data { |
115 | my ($self, %args) = @_; |
116 | |
117 | my $fh = IO::File->new("> $args{file}") or die "Can't create '$args{file}': $!"; |
118 | |
119 | printf $fh <<'EOF', $args{config_module}; |
120 | package %s; |
121 | use strict; |
122 | my $arrayref = eval do {local $/; <DATA>} |
123 | or die "Couldn't load ConfigData data: $@"; |
124 | close DATA; |
125 | my ($config, $features, $auto_features) = @$arrayref; |
126 | |
127 | sub config { $config->{$_[1]} } |
128 | |
129 | sub set_config { $config->{$_[1]} = $_[2] } |
130 | sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0 |
131 | |
132 | sub auto_feature_names { grep !exists $features->{$_}, keys %%$auto_features } |
133 | |
134 | sub feature_names { |
135 | my @features = (keys %%$features, auto_feature_names()); |
136 | @features; |
137 | } |
138 | |
139 | sub config_names { keys %%$config } |
140 | |
141 | sub write { |
142 | my $me = __FILE__; |
143 | require IO::File; |
7a827510 |
144 | |
145 | # Can't use Module::Build::Dumper here because M::B is only a |
146 | # build-time prereq of this module |
bb4e9162 |
147 | require Data::Dumper; |
148 | |
149 | my $mode_orig = (stat $me)[2] & 07777; |
150 | chmod($mode_orig | 0222, $me); # Make it writeable |
151 | my $fh = IO::File->new($me, 'r+') or die "Can't rewrite $me: $!"; |
152 | seek($fh, 0, 0); |
153 | while (<$fh>) { |
154 | last if /^__DATA__$/; |
155 | } |
156 | die "Couldn't find __DATA__ token in $me" if eof($fh); |
157 | |
bb4e9162 |
158 | seek($fh, tell($fh), 0); |
7a827510 |
159 | my $data = [$config, $features, $auto_features]; |
160 | $fh->print( 'do{ my ' |
161 | . Data::Dumper->new([$data],['x'])->Purity(1)->Dump() |
162 | . '$x; }' ); |
bb4e9162 |
163 | truncate($fh, tell($fh)); |
164 | $fh->close; |
165 | |
166 | chmod($mode_orig, $me) |
167 | or warn "Couldn't restore permissions on $me: $!"; |
168 | } |
169 | |
170 | sub feature { |
171 | my ($package, $key) = @_; |
172 | return $features->{$key} if exists $features->{$key}; |
173 | |
174 | my $info = $auto_features->{$key} or return 0; |
175 | |
176 | # Under perl 5.005, each(%%$foo) isn't working correctly when $foo |
177 | # was reanimated with Data::Dumper and eval(). Not sure why, but |
178 | # copying to a new hash seems to solve it. |
179 | my %%info = %%$info; |
180 | |
181 | require Module::Build; # XXX should get rid of this |
182 | while (my ($type, $prereqs) = each %%info) { |
183 | next if $type eq 'description' || $type eq 'recommends'; |
184 | |
185 | my %%p = %%$prereqs; # Ditto here. |
186 | while (my ($modname, $spec) = each %%p) { |
187 | my $status = Module::Build->check_installed_status($modname, $spec); |
188 | if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; } |
189 | } |
190 | } |
191 | return 1; |
192 | } |
193 | |
194 | EOF |
195 | |
196 | my ($module_name, $notes_name) = ($args{module}, $args{config_module}); |
197 | printf $fh <<"EOF", $notes_name, $module_name; |
198 | |
199 | =head1 NAME |
200 | |
201 | $notes_name - Configuration for $module_name |
202 | |
203 | |
204 | =head1 SYNOPSIS |
205 | |
206 | use $notes_name; |
207 | \$value = $notes_name->config('foo'); |
208 | \$value = $notes_name->feature('bar'); |
209 | |
210 | \@names = $notes_name->config_names; |
211 | \@names = $notes_name->feature_names; |
212 | |
213 | $notes_name->set_config(foo => \$new_value); |
214 | $notes_name->set_feature(bar => \$new_value); |
215 | $notes_name->write; # Save changes |
216 | |
217 | |
218 | =head1 DESCRIPTION |
219 | |
220 | This module holds the configuration data for the C<$module_name> |
221 | module. It also provides a programmatic interface for getting or |
222 | setting that configuration data. Note that in order to actually make |
223 | changes, you'll have to have write access to the C<$notes_name> |
224 | module, and you should attempt to understand the repercussions of your |
225 | actions. |
226 | |
227 | |
228 | =head1 METHODS |
229 | |
230 | =over 4 |
231 | |
232 | =item config(\$name) |
233 | |
234 | Given a string argument, returns the value of the configuration item |
235 | by that name, or C<undef> if no such item exists. |
236 | |
237 | =item feature(\$name) |
238 | |
239 | Given a string argument, returns the value of the feature by that |
240 | name, or C<undef> if no such feature exists. |
241 | |
242 | =item set_config(\$name, \$value) |
243 | |
244 | Sets the configuration item with the given name to the given value. |
245 | The value may be any Perl scalar that will serialize correctly using |
246 | C<Data::Dumper>. This includes references, objects (usually), and |
247 | complex data structures. It probably does not include transient |
248 | things like filehandles or sockets. |
249 | |
250 | =item set_feature(\$name, \$value) |
251 | |
252 | Sets the feature with the given name to the given boolean value. The |
253 | value will be converted to 0 or 1 automatically. |
254 | |
255 | =item config_names() |
256 | |
257 | Returns a list of all the names of config items currently defined in |
258 | C<$notes_name>, or in scalar context the number of items. |
259 | |
260 | =item feature_names() |
261 | |
262 | Returns a list of all the names of features currently defined in |
263 | C<$notes_name>, or in scalar context the number of features. |
264 | |
265 | =item auto_feature_names() |
266 | |
267 | Returns a list of all the names of features whose availability is |
268 | dynamically determined, or in scalar context the number of such |
269 | features. Does not include such features that have later been set to |
270 | a fixed value. |
271 | |
272 | =item write() |
273 | |
274 | Commits any changes from C<set_config()> and C<set_feature()> to disk. |
275 | Requires write access to the C<$notes_name> module. |
276 | |
277 | =back |
278 | |
279 | |
280 | =head1 AUTHOR |
281 | |
282 | C<$notes_name> was automatically created using C<Module::Build>. |
283 | C<Module::Build> was written by Ken Williams, but he holds no |
284 | authorship claim or copyright claim to the contents of C<$notes_name>. |
285 | |
286 | =cut |
287 | |
288 | __DATA__ |
289 | |
290 | EOF |
291 | |
7a827510 |
292 | print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]); |
bb4e9162 |
293 | } |
294 | |
295 | 1; |