Update Module::Build to 0.35
[perl.git] / 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.35';
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 sub 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};
120 package %s;
121 use strict;
122 my $arrayref = eval do {local $/; <DATA>}
123   or die "Couldn't load ConfigData data: $@";
124 close DATA;
125 my ($config, $features, $auto_features) = @$arrayref;
126
127 sub config { $config->{$_[1]} }
128
129 sub set_config { $config->{$_[1]} = $_[2] }
130 sub set_feature { $features->{$_[1]} = 0+!!$_[2] }  # Constrain to 1 or 0
131
132 sub auto_feature_names { grep !exists $features->{$_}, keys %%$auto_features }
133
134 sub feature_names {
135   my @features = (keys %%$features, auto_feature_names());
136   @features;
137 }
138
139 sub config_names  { keys %%$config }
140
141 sub write {
142   my $me = __FILE__;
143   require IO::File;
144
145   # Can't use Module::Build::Dumper here because M::B is only a
146   # build-time prereq of this module
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
158   seek($fh, tell($fh), 0);
159   my $data = [$config, $features, $auto_features];
160   $fh->print( 'do{ my '
161               . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
162               . '$x; }' );
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
170 sub 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; }
189       if ( ! eval "require $modname; 1" ) { return 0; }
190     }
191   }
192   return 1;
193 }
194
195 EOF
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
221 This module holds the configuration data for the C<$module_name>
222 module.  It also provides a programmatic interface for getting or
223 setting that configuration data.  Note that in order to actually make
224 changes, you'll have to have write access to the C<$notes_name>
225 module, and you should attempt to understand the repercussions of your
226 actions.
227
228
229 =head1 METHODS
230
231 =over 4
232
233 =item config(\$name)
234
235 Given a string argument, returns the value of the configuration item
236 by that name, or C<undef> if no such item exists.
237
238 =item feature(\$name)
239
240 Given a string argument, returns the value of the feature by that
241 name, or C<undef> if no such feature exists.
242
243 =item set_config(\$name, \$value)
244
245 Sets the configuration item with the given name to the given value.
246 The value may be any Perl scalar that will serialize correctly using
247 C<Data::Dumper>.  This includes references, objects (usually), and
248 complex data structures.  It probably does not include transient
249 things like filehandles or sockets.
250
251 =item set_feature(\$name, \$value)
252
253 Sets the feature with the given name to the given boolean value.  The
254 value will be converted to 0 or 1 automatically.
255
256 =item config_names()
257
258 Returns a list of all the names of config items currently defined in
259 C<$notes_name>, or in scalar context the number of items.
260
261 =item feature_names()
262
263 Returns a list of all the names of features currently defined in
264 C<$notes_name>, or in scalar context the number of features.
265
266 =item auto_feature_names()
267
268 Returns a list of all the names of features whose availability is
269 dynamically determined, or in scalar context the number of such
270 features.  Does not include such features that have later been set to
271 a fixed value.
272
273 =item write()
274
275 Commits any changes from C<set_config()> and C<set_feature()> to disk.
276 Requires write access to the C<$notes_name> module.
277
278 =back
279
280
281 =head1 AUTHOR
282
283 C<$notes_name> was automatically created using C<Module::Build>.
284 C<Module::Build> was written by Ken Williams, but he holds no
285 authorship claim or copyright claim to the contents of C<$notes_name>.
286
287 =cut
288
289 __DATA__
290
291 EOF
292
293   print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
294 }
295
296 1;