This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Typo fix
[perl5.git] / cpan / Module-Build / lib / Module / Build / Notes.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Notes;
2
3# A class for persistent hashes
4
5use strict;
7a827510 6use vars qw($VERSION);
cdbde1c3 7$VERSION = '0.35';
7a827510 8$VERSION = eval $VERSION;
bb4e9162
YST
9use Data::Dumper;
10use IO::File;
7a827510 11use Module::Build::Dumper;
bb4e9162 12
bb4e9162
YST
13sub 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
24sub 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
33sub 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
45sub has_data {
46 my $self = shift;
47 return keys %{$self->read()} > 0;
48}
49
50sub exists {
51 my ($self, $key) = @_;
52 return exists($self->{new}{$key}) || exists($self->{disk}{$key});
53}
54
55sub 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
72sub _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
79sub 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
107sub _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
YST
112}
113
114sub 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};
120package %s;
121use strict;
122my $arrayref = eval do {local $/; <DATA>}
123 or die "Couldn't load ConfigData data: $@";
124close DATA;
125my ($config, $features, $auto_features) = @$arrayref;
126
127sub config { $config->{$_[1]} }
128
129sub set_config { $config->{$_[1]} = $_[2] }
130sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0
131
132sub auto_feature_names { grep !exists $features->{$_}, keys %%$auto_features }
133
134sub feature_names {
135 my @features = (keys %%$features, auto_feature_names());
136 @features;
137}
138
139sub config_names { keys %%$config }
140
141sub write {
142 my $me = __FILE__;
143 require IO::File;
7a827510
RGS
144
145 # Can't use Module::Build::Dumper here because M::B is only a
146 # build-time prereq of this module
bb4e9162
YST
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
RGS
159 my $data = [$config, $features, $auto_features];
160 $fh->print( 'do{ my '
161 . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
162 . '$x; }' );
bb4e9162
YST
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
170sub 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; }
23837600 189 if ( ! eval "require $modname; 1" ) { return 0; }
bb4e9162
YST
190 }
191 }
192 return 1;
193}
194
195EOF
196
197 my ($module_name, $notes_name) = ($args{module}, $args{config_module});
198 printf $fh <<"EOF", $notes_name, $module_name;
199
200=head1 NAME
201
202$notes_name - Configuration for $module_name
203
204
205=head1 SYNOPSIS
206
207 use $notes_name;
208 \$value = $notes_name->config('foo');
209 \$value = $notes_name->feature('bar');
210
211 \@names = $notes_name->config_names;
212 \@names = $notes_name->feature_names;
213
214 $notes_name->set_config(foo => \$new_value);
215 $notes_name->set_feature(bar => \$new_value);
216 $notes_name->write; # Save changes
217
218
219=head1 DESCRIPTION
220
221This module holds the configuration data for the C<$module_name>
222module. It also provides a programmatic interface for getting or
223setting that configuration data. Note that in order to actually make
224changes, you'll have to have write access to the C<$notes_name>
225module, and you should attempt to understand the repercussions of your
226actions.
227
228
229=head1 METHODS
230
231=over 4
232
233=item config(\$name)
234
235Given a string argument, returns the value of the configuration item
236by that name, or C<undef> if no such item exists.
237
238=item feature(\$name)
239
240Given a string argument, returns the value of the feature by that
241name, or C<undef> if no such feature exists.
242
243=item set_config(\$name, \$value)
244
245Sets the configuration item with the given name to the given value.
246The value may be any Perl scalar that will serialize correctly using
247C<Data::Dumper>. This includes references, objects (usually), and
248complex data structures. It probably does not include transient
249things like filehandles or sockets.
250
251=item set_feature(\$name, \$value)
252
253Sets the feature with the given name to the given boolean value. The
254value will be converted to 0 or 1 automatically.
255
256=item config_names()
257
258Returns a list of all the names of config items currently defined in
259C<$notes_name>, or in scalar context the number of items.
260
261=item feature_names()
262
263Returns a list of all the names of features currently defined in
264C<$notes_name>, or in scalar context the number of features.
265
266=item auto_feature_names()
267
268Returns a list of all the names of features whose availability is
269dynamically determined, or in scalar context the number of such
270features. Does not include such features that have later been set to
271a fixed value.
272
273=item write()
274
275Commits any changes from C<set_config()> and C<set_feature()> to disk.
276Requires write access to the C<$notes_name> module.
277
278=back
279
280
281=head1 AUTHOR
282
283C<$notes_name> was automatically created using C<Module::Build>.
284C<Module::Build> was written by Ken Williams, but he holds no
285authorship claim or copyright claim to the contents of C<$notes_name>.
286
287=cut
288
289__DATA__
290
291EOF
292
7a827510 293 print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
bb4e9162
YST
294}
295
2961;