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