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); |
53fc1c7e |
7 | $VERSION = '0.35_14'; |
7a827510 |
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 @_; |
53fc1c7e |
36 | |
bb4e9162 |
37 | my $key = shift; |
38 | return $self->read($key) unless @_; |
53fc1c7e |
39 | |
bb4e9162 |
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 | } |
53fc1c7e |
64 | |
bb4e9162 |
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 ||= {}; |
53fc1c7e |
82 | |
bb4e9162 |
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 | } |
53fc1c7e |
91 | |
bb4e9162 |
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 |
53fc1c7e |
98 | |
99 | @{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}}; # Merge |
bb4e9162 |
100 | $self->_dump($file, $self->{disk}); |
53fc1c7e |
101 | |
bb4e9162 |
102 | $self->{new} = {}; |
103 | } |
104 | return $self->read; |
105 | } |
106 | |
107 | sub _dump { |
108 | my ($self, $file, $data) = @_; |
53fc1c7e |
109 | |
bb4e9162 |
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 | |
613f422f |
114 | my $orig_template = do { local $/; <DATA> }; |
115 | close DATA; |
116 | |
bb4e9162 |
117 | sub write_config_data { |
118 | my ($self, %args) = @_; |
119 | |
613f422f |
120 | my $template = $orig_template; |
121 | $template =~ s/NOTES_NAME/$args{config_module}/g; |
122 | $template =~ s/MODULE_NAME/$args{module}/g; |
123 | $template =~ s/=begin private\n//; |
124 | $template =~ s/=end private/=cut/; |
125 | |
126 | # strip out private POD markers we use to keep pod from being |
127 | # recognized for *this* source file |
128 | $template =~ s{$_\n}{} for '=begin private', '=end private'; |
53fc1c7e |
129 | |
bb4e9162 |
130 | my $fh = IO::File->new("> $args{file}") or die "Can't create '$args{file}': $!"; |
613f422f |
131 | print {$fh} $template; |
132 | print {$fh} "\n__DATA__\n"; |
133 | print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]); |
134 | |
135 | } |
136 | |
137 | 1; |
138 | |
139 | |
140 | =head1 NAME |
141 | |
142 | Module::Build::Notes - Create persistent distribution configuration modules |
143 | |
144 | =head1 DESCRIPTION |
145 | |
146 | This module is used internally by Module::Build to create persistent |
147 | configuration files that can be installed with a distribution. See |
148 | L<Module::Build::ConfigData> for an example. |
149 | |
150 | =head1 AUTHOR |
bb4e9162 |
151 | |
613f422f |
152 | Ken Williams <kwilliams@cpan.org> |
153 | |
154 | =head1 COPYRIGHT |
155 | |
156 | Copyright (c) 2001-2006 Ken Williams. All rights reserved. |
157 | |
158 | This library is free software; you can redistribute it and/or |
159 | modify it under the same terms as Perl itself. |
160 | |
161 | =head1 SEE ALSO |
162 | |
163 | perl(1), L<Module::Build>(3) |
164 | |
165 | =cut |
166 | |
167 | __DATA__ |
168 | package NOTES_NAME; |
bb4e9162 |
169 | use strict; |
170 | my $arrayref = eval do {local $/; <DATA>} |
171 | or die "Couldn't load ConfigData data: $@"; |
172 | close DATA; |
173 | my ($config, $features, $auto_features) = @$arrayref; |
174 | |
175 | sub config { $config->{$_[1]} } |
176 | |
177 | sub set_config { $config->{$_[1]} = $_[2] } |
178 | sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0 |
179 | |
613f422f |
180 | sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features } |
bb4e9162 |
181 | |
182 | sub feature_names { |
613f422f |
183 | my @features = (keys %$features, auto_feature_names()); |
bb4e9162 |
184 | @features; |
185 | } |
186 | |
613f422f |
187 | sub config_names { keys %$config } |
bb4e9162 |
188 | |
189 | sub write { |
190 | my $me = __FILE__; |
191 | require IO::File; |
7a827510 |
192 | |
193 | # Can't use Module::Build::Dumper here because M::B is only a |
194 | # build-time prereq of this module |
bb4e9162 |
195 | require Data::Dumper; |
196 | |
197 | my $mode_orig = (stat $me)[2] & 07777; |
198 | chmod($mode_orig | 0222, $me); # Make it writeable |
199 | my $fh = IO::File->new($me, 'r+') or die "Can't rewrite $me: $!"; |
200 | seek($fh, 0, 0); |
201 | while (<$fh>) { |
202 | last if /^__DATA__$/; |
203 | } |
204 | die "Couldn't find __DATA__ token in $me" if eof($fh); |
205 | |
bb4e9162 |
206 | seek($fh, tell($fh), 0); |
7a827510 |
207 | my $data = [$config, $features, $auto_features]; |
208 | $fh->print( 'do{ my ' |
209 | . Data::Dumper->new([$data],['x'])->Purity(1)->Dump() |
210 | . '$x; }' ); |
bb4e9162 |
211 | truncate($fh, tell($fh)); |
212 | $fh->close; |
213 | |
214 | chmod($mode_orig, $me) |
215 | or warn "Couldn't restore permissions on $me: $!"; |
216 | } |
217 | |
218 | sub feature { |
219 | my ($package, $key) = @_; |
220 | return $features->{$key} if exists $features->{$key}; |
53fc1c7e |
221 | |
bb4e9162 |
222 | my $info = $auto_features->{$key} or return 0; |
53fc1c7e |
223 | |
613f422f |
224 | # Under perl 5.005, each(%$foo) isn't working correctly when $foo |
bb4e9162 |
225 | # was reanimated with Data::Dumper and eval(). Not sure why, but |
226 | # copying to a new hash seems to solve it. |
613f422f |
227 | my %info = %$info; |
53fc1c7e |
228 | |
bb4e9162 |
229 | require Module::Build; # XXX should get rid of this |
613f422f |
230 | while (my ($type, $prereqs) = each %info) { |
bb4e9162 |
231 | next if $type eq 'description' || $type eq 'recommends'; |
53fc1c7e |
232 | |
613f422f |
233 | my %p = %$prereqs; # Ditto here. |
234 | while (my ($modname, $spec) = each %p) { |
bb4e9162 |
235 | my $status = Module::Build->check_installed_status($modname, $spec); |
236 | if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; } |
23837600 |
237 | if ( ! eval "require $modname; 1" ) { return 0; } |
bb4e9162 |
238 | } |
239 | } |
240 | return 1; |
241 | } |
242 | |
613f422f |
243 | =begin private |
bb4e9162 |
244 | |
245 | =head1 NAME |
246 | |
613f422f |
247 | NOTES_NAME - Configuration for MODULE_NAME |
bb4e9162 |
248 | |
249 | =head1 SYNOPSIS |
250 | |
613f422f |
251 | use NOTES_NAME; |
252 | $value = NOTES_NAME->config('foo'); |
253 | $value = NOTES_NAME->feature('bar'); |
53fc1c7e |
254 | |
613f422f |
255 | @names = NOTES_NAME->config_names; |
256 | @names = NOTES_NAME->feature_names; |
53fc1c7e |
257 | |
613f422f |
258 | NOTES_NAME->set_config(foo => $new_value); |
259 | NOTES_NAME->set_feature(bar => $new_value); |
260 | NOTES_NAME->write; # Save changes |
bb4e9162 |
261 | |
262 | |
263 | =head1 DESCRIPTION |
264 | |
613f422f |
265 | This module holds the configuration data for the C<MODULE_NAME> |
bb4e9162 |
266 | module. It also provides a programmatic interface for getting or |
267 | setting that configuration data. Note that in order to actually make |
613f422f |
268 | changes, you'll have to have write access to the C<NOTES_NAME> |
bb4e9162 |
269 | module, and you should attempt to understand the repercussions of your |
270 | actions. |
271 | |
272 | |
273 | =head1 METHODS |
274 | |
275 | =over 4 |
276 | |
613f422f |
277 | =item config($name) |
bb4e9162 |
278 | |
279 | Given a string argument, returns the value of the configuration item |
280 | by that name, or C<undef> if no such item exists. |
281 | |
613f422f |
282 | =item feature($name) |
bb4e9162 |
283 | |
284 | Given a string argument, returns the value of the feature by that |
285 | name, or C<undef> if no such feature exists. |
286 | |
613f422f |
287 | =item set_config($name, $value) |
bb4e9162 |
288 | |
289 | Sets the configuration item with the given name to the given value. |
290 | The value may be any Perl scalar that will serialize correctly using |
291 | C<Data::Dumper>. This includes references, objects (usually), and |
292 | complex data structures. It probably does not include transient |
293 | things like filehandles or sockets. |
294 | |
613f422f |
295 | =item set_feature($name, $value) |
bb4e9162 |
296 | |
297 | Sets the feature with the given name to the given boolean value. The |
298 | value will be converted to 0 or 1 automatically. |
299 | |
300 | =item config_names() |
301 | |
302 | Returns a list of all the names of config items currently defined in |
613f422f |
303 | C<NOTES_NAME>, or in scalar context the number of items. |
bb4e9162 |
304 | |
305 | =item feature_names() |
306 | |
307 | Returns a list of all the names of features currently defined in |
613f422f |
308 | C<NOTES_NAME>, or in scalar context the number of features. |
bb4e9162 |
309 | |
310 | =item auto_feature_names() |
311 | |
312 | Returns a list of all the names of features whose availability is |
313 | dynamically determined, or in scalar context the number of such |
314 | features. Does not include such features that have later been set to |
315 | a fixed value. |
316 | |
317 | =item write() |
318 | |
319 | Commits any changes from C<set_config()> and C<set_feature()> to disk. |
613f422f |
320 | Requires write access to the C<NOTES_NAME> module. |
bb4e9162 |
321 | |
322 | =back |
323 | |
324 | |
325 | =head1 AUTHOR |
326 | |
613f422f |
327 | C<NOTES_NAME> was automatically created using C<Module::Build>. |
bb4e9162 |
328 | C<Module::Build> was written by Ken Williams, but he holds no |
613f422f |
329 | authorship claim or copyright claim to the contents of C<NOTES_NAME>. |
bb4e9162 |
330 | |
613f422f |
331 | =end private |
bb4e9162 |
332 | |