This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add Module::Build 0.27_08
[perl5.git] / lib / Module / Build / Notes.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Notes;
2
3# A class for persistent hashes
4
5use strict;
6use Data::Dumper;
7use IO::File;
8
9use Carp; BEGIN{ $SIG{__DIE__} = \&carp::confess }
10
11sub 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
22sub 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
31sub 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
43sub has_data {
44 my $self = shift;
45 return keys %{$self->read()} > 0;
46}
47
48sub exists {
49 my ($self, $key) = @_;
50 return exists($self->{new}{$key}) || exists($self->{disk}{$key});
51}
52
53sub 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
70sub _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
77sub 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
105sub _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
113sub 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};
119package %s;
120use strict;
121my $arrayref = eval do {local $/; <DATA>}
122 or die "Couldn't load ConfigData data: $@";
123close DATA;
124my ($config, $features, $auto_features) = @$arrayref;
125
126sub config { $config->{$_[1]} }
127
128sub set_config { $config->{$_[1]} = $_[2] }
129sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0
130
131sub auto_feature_names { grep !exists $features->{$_}, keys %%$auto_features }
132
133sub feature_names {
134 my @features = (keys %%$features, auto_feature_names());
135 @features;
136}
137
138sub config_names { keys %%$config }
139
140sub 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
164sub 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
188EOF
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
214This module holds the configuration data for the C<$module_name>
215module. It also provides a programmatic interface for getting or
216setting that configuration data. Note that in order to actually make
217changes, you'll have to have write access to the C<$notes_name>
218module, and you should attempt to understand the repercussions of your
219actions.
220
221
222=head1 METHODS
223
224=over 4
225
226=item config(\$name)
227
228Given a string argument, returns the value of the configuration item
229by that name, or C<undef> if no such item exists.
230
231=item feature(\$name)
232
233Given a string argument, returns the value of the feature by that
234name, or C<undef> if no such feature exists.
235
236=item set_config(\$name, \$value)
237
238Sets the configuration item with the given name to the given value.
239The value may be any Perl scalar that will serialize correctly using
240C<Data::Dumper>. This includes references, objects (usually), and
241complex data structures. It probably does not include transient
242things like filehandles or sockets.
243
244=item set_feature(\$name, \$value)
245
246Sets the feature with the given name to the given boolean value. The
247value will be converted to 0 or 1 automatically.
248
249=item config_names()
250
251Returns a list of all the names of config items currently defined in
252C<$notes_name>, or in scalar context the number of items.
253
254=item feature_names()
255
256Returns a list of all the names of features currently defined in
257C<$notes_name>, or in scalar context the number of features.
258
259=item auto_feature_names()
260
261Returns a list of all the names of features whose availability is
262dynamically determined, or in scalar context the number of such
263features. Does not include such features that have later been set to
264a fixed value.
265
266=item write()
267
268Commits any changes from C<set_config()> and C<set_feature()> to disk.
269Requires write access to the C<$notes_name> module.
270
271=back
272
273
274=head1 AUTHOR
275
276C<$notes_name> was automatically created using C<Module::Build>.
277C<Module::Build> was written by Ken Williams, but he holds no
278authorship claim or copyright claim to the contents of C<$notes_name>.
279
280=cut
281
282__DATA__
283
284EOF
285
286 local $Data::Dumper::Terse = 1;
287 print $fh Data::Dumper::Dumper([$args{config_data}, $args{feature}, $args{auto_features}]);
288}
289
2901;