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