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