92fa7c0d104aacf991548b7b023ab9a90de960ba
[perl.git] / cpan / Module-Build / lib / Module / Build / Notes.pm
1 package Module::Build::Notes;
2
3 # A class for persistent hashes
4
5 use strict;
6 use vars qw($VERSION);
7 $VERSION = '0.37_05';
8 $VERSION = eval $VERSION;
9 use Data::Dumper;
10 use IO::File;
11 use Module::Build::Dumper;
12
13 sub 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
24 sub 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
33 sub 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
45 sub has_data {
46   my $self = shift;
47   return keys %{$self->read()} > 0;
48 }
49
50 sub exists {
51   my ($self, $key) = @_;
52   return exists($self->{new}{$key}) || exists($self->{disk}{$key});
53 }
54
55 sub 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
72 sub _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
79 sub 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
107 sub _dump {
108   my ($self, $file, $data) = @_;
109
110   my $fh = IO::File->new("> $file") or die "Can't create '$file': $!";
111   print {$fh} Module::Build::Dumper->_data_dump($data);
112 }
113
114 my $orig_template = do { local $/; <DATA> };
115 close DATA;
116
117 sub write_config_data {
118   my ($self, %args) = @_;
119
120   my $template = $orig_template;
121   $template =~ s/NOTES_NAME/$args{config_module}/g;
122   $template =~ s/MODULE_NAME/$args{module}/g;
123   $template =~ s/=begin private\n//;
124   $template =~ s/=end private/=cut/;
125
126   # strip out private POD markers we use to keep pod from being
127   # recognized for *this* source file
128   $template =~ s{$_\n}{} for '=begin private', '=end private';
129
130   my $fh = IO::File->new("> $args{file}") or die "Can't create '$args{file}': $!";
131   print {$fh} $template;
132   print {$fh} "\n__DATA__\n";
133   print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
134
135 }
136
137 1;
138
139
140 =head1 NAME
141
142 Module::Build::Notes - Create persistent distribution configuration modules
143
144 =head1 DESCRIPTION
145
146 This module is used internally by Module::Build to create persistent
147 configuration files that can be installed with a distribution.  See
148 L<Module::Build::ConfigData> for an example.
149
150 =head1 AUTHOR
151
152 Ken Williams <kwilliams@cpan.org>
153
154 =head1 COPYRIGHT
155
156 Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
157
158 This library is free software; you can redistribute it and/or
159 modify it under the same terms as Perl itself.
160
161 =head1 SEE ALSO
162
163 perl(1), L<Module::Build>(3)
164
165 =cut
166
167 __DATA__
168 package NOTES_NAME;
169 use strict;
170 my $arrayref = eval do {local $/; <DATA>}
171   or die "Couldn't load ConfigData data: $@";
172 close DATA;
173 my ($config, $features, $auto_features) = @$arrayref;
174
175 sub config { $config->{$_[1]} }
176
177 sub set_config { $config->{$_[1]} = $_[2] }
178 sub set_feature { $features->{$_[1]} = 0+!!$_[2] }  # Constrain to 1 or 0
179
180 sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features }
181
182 sub feature_names {
183   my @features = (keys %$features, auto_feature_names());
184   @features;
185 }
186
187 sub config_names  { keys %$config }
188
189 sub write {
190   my $me = __FILE__;
191   require IO::File;
192
193   # Can't use Module::Build::Dumper here because M::B is only a
194   # build-time prereq of this module
195   require Data::Dumper;
196
197   my $mode_orig = (stat $me)[2] & 07777;
198   chmod($mode_orig | 0222, $me); # Make it writeable
199   my $fh = IO::File->new($me, 'r+') or die "Can't rewrite $me: $!";
200   seek($fh, 0, 0);
201   while (<$fh>) {
202     last if /^__DATA__$/;
203   }
204   die "Couldn't find __DATA__ token in $me" if eof($fh);
205
206   seek($fh, tell($fh), 0);
207   my $data = [$config, $features, $auto_features];
208   $fh->print( 'do{ my '
209               . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
210               . '$x; }' );
211   truncate($fh, tell($fh));
212   $fh->close;
213
214   chmod($mode_orig, $me)
215     or warn "Couldn't restore permissions on $me: $!";
216 }
217
218 sub feature {
219   my ($package, $key) = @_;
220   return $features->{$key} if exists $features->{$key};
221
222   my $info = $auto_features->{$key} or return 0;
223
224   # Under perl 5.005, each(%$foo) isn't working correctly when $foo
225   # was reanimated with Data::Dumper and eval().  Not sure why, but
226   # copying to a new hash seems to solve it.
227   my %info = %$info;
228
229   require Module::Build;  # XXX should get rid of this
230   while (my ($type, $prereqs) = each %info) {
231     next if $type eq 'description' || $type eq 'recommends';
232
233     my %p = %$prereqs;  # Ditto here.
234     while (my ($modname, $spec) = each %p) {
235       my $status = Module::Build->check_installed_status($modname, $spec);
236       if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
237       if ( ! eval "require $modname; 1" ) { return 0; }
238     }
239   }
240   return 1;
241 }
242
243 =begin private
244
245 =head1 NAME
246
247 NOTES_NAME - Configuration for MODULE_NAME
248
249 =head1 SYNOPSIS
250
251   use NOTES_NAME;
252   $value = NOTES_NAME->config('foo');
253   $value = NOTES_NAME->feature('bar');
254
255   @names = NOTES_NAME->config_names;
256   @names = NOTES_NAME->feature_names;
257
258   NOTES_NAME->set_config(foo => $new_value);
259   NOTES_NAME->set_feature(bar => $new_value);
260   NOTES_NAME->write;  # Save changes
261
262
263 =head1 DESCRIPTION
264
265 This module holds the configuration data for the C<MODULE_NAME>
266 module.  It also provides a programmatic interface for getting or
267 setting that configuration data.  Note that in order to actually make
268 changes, you'll have to have write access to the C<NOTES_NAME>
269 module, and you should attempt to understand the repercussions of your
270 actions.
271
272
273 =head1 METHODS
274
275 =over 4
276
277 =item config($name)
278
279 Given a string argument, returns the value of the configuration item
280 by that name, or C<undef> if no such item exists.
281
282 =item feature($name)
283
284 Given a string argument, returns the value of the feature by that
285 name, or C<undef> if no such feature exists.
286
287 =item set_config($name, $value)
288
289 Sets the configuration item with the given name to the given value.
290 The value may be any Perl scalar that will serialize correctly using
291 C<Data::Dumper>.  This includes references, objects (usually), and
292 complex data structures.  It probably does not include transient
293 things like filehandles or sockets.
294
295 =item set_feature($name, $value)
296
297 Sets the feature with the given name to the given boolean value.  The
298 value will be converted to 0 or 1 automatically.
299
300 =item config_names()
301
302 Returns a list of all the names of config items currently defined in
303 C<NOTES_NAME>, or in scalar context the number of items.
304
305 =item feature_names()
306
307 Returns a list of all the names of features currently defined in
308 C<NOTES_NAME>, or in scalar context the number of features.
309
310 =item auto_feature_names()
311
312 Returns a list of all the names of features whose availability is
313 dynamically determined, or in scalar context the number of such
314 features.  Does not include such features that have later been set to
315 a fixed value.
316
317 =item write()
318
319 Commits any changes from C<set_config()> and C<set_feature()> to disk.
320 Requires write access to the C<NOTES_NAME> module.
321
322 =back
323
324
325 =head1 AUTHOR
326
327 C<NOTES_NAME> was automatically created using C<Module::Build>.
328 C<Module::Build> was written by Ken Williams, but he holds no
329 authorship claim or copyright claim to the contents of C<NOTES_NAME>.
330
331 =end private
332