lib/Module/Build/Notes.pm

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