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 use Carp; BEGIN{ $SIG{__DIE__} = \&carp::confess }
  10
  11 sub new {
  12   my ($class, %args) = @_;
  13   my $file = delete $args{file} or die "Missing required parameter 'file' to new()";
  14   my $self = bless {
  15                     disk => {},
  16                     new  => {},
  17                     file => $file,
  18                     %args,
  19                    }, $class;
  20 }
  21
  22 sub restore {
  23   my $self = shift;
  24
  25   my $fh = IO::File->new("< $self->{file}") or die "Can't read $self->{file}: $!";
  26   $self->{disk} = eval do {local $/; <$fh>};
  27   die $@ if $@;
  28   $self->{new} = {};
  29 }
  30
  31 sub access {
  32   my $self = shift;
  33   return $self->read() unless @_;
  34
  35   my $key = shift;
  36   return $self->read($key) unless @_;
  37
  38   my $value = shift;
  39   $self->write({ $key => $value });
  40   return $self->read($key);
  41 }
  42
  43 sub has_data {
  44   my $self = shift;
  45   return keys %{$self->read()} > 0;
  46 }
  47
  48 sub exists {
  49   my ($self, $key) = @_;
  50   return exists($self->{new}{$key}) || exists($self->{disk}{$key});
  51 }
  52
  53 sub read {
  54   my $self = shift;
  55
  56   if (@_) {
  57     # Return 1 key as a scalar
  58     my $key = shift;
  59     return $self->{new}{$key} if exists $self->{new}{$key};
  60     return $self->{disk}{$key};
  61   }
  62
  63   # Return all data
  64   my $out = (keys %{$self->{new}}
  65              ? {%{$self->{disk}}, %{$self->{new}}}
  66              : $self->{disk});
  67   return wantarray ? %$out : $out;
  68 }
  69
  70 sub _same {
  71   my ($self, $x, $y) = @_;
  72   return 1 if !defined($x) and !defined($y);
  73   return 0 if !defined($x) or  !defined($y);
  74   return $x eq $y;
  75 }
  76
  77 sub write {
  78   my ($self, $href) = @_;
  79   $href ||= {};
  80
  81   @{$self->{new}}{ keys %$href } = values %$href;  # Merge
  82
  83   # Do some optimization to avoid unnecessary writes
  84   foreach my $key (keys %{ $self->{new} }) {
  85     next if ref $self->{new}{$key};
  86     next if ref $self->{disk}{$key} or !exists $self->{disk}{$key};
  87     delete $self->{new}{$key} if $self->_same($self->{new}{$key}, $self->{disk}{$key});
  88   }
  89
  90   if (my $file = $self->{file}) {
  91     my ($vol, $dir, $base) = File::Spec->splitpath($file);
  92     $dir = File::Spec->catpath($vol, $dir, '');
  93     return unless -e $dir && -d $dir;  # The user needs to arrange for this
  94
  95     return if -e $file and !keys %{ $self->{new} };  # Nothing to do
  96
  97     @{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}};  # Merge
  98     $self->_dump($file, $self->{disk});
  99
 100     $self->{new} = {};
 101   }
 102   return $self->read;
 103 }
 104
 105 sub _dump {
 106   my ($self, $file, $data) = @_;
 107
 108   my $fh = IO::File->new("> $file") or die "Can't create '$file': $!";
 109   local $Data::Dumper::Terse = 1;
 110   print $fh Data::Dumper::Dumper($data);
 111 }
 112
 113 sub write_config_data {
 114   my ($self, %args) = @_;
 115
 116   my $fh = IO::File->new("> $args{file}") or die "Can't create '$args{file}': $!";
 117
 118   printf $fh <<'EOF', $args{config_module};
 119 package %s;
 120 use strict;
 121 my $arrayref = eval do {local $/; <DATA>}
 122   or die "Couldn't load ConfigData data: $@";
 123 close DATA;
 124 my ($config, $features, $auto_features) = @$arrayref;
 125
 126 sub config { $config->{$_[1]} }
 127
 128 sub set_config { $config->{$_[1]} = $_[2] }
 129 sub set_feature { $features->{$_[1]} = 0+!!$_[2] }  # Constrain to 1 or 0
 130
 131 sub auto_feature_names { grep !exists $features->{$_}, keys %%$auto_features }
 132
 133 sub feature_names {
 134   my @features = (keys %%$features, auto_feature_names());
 135   @features;
 136 }
 137
 138 sub config_names  { keys %%$config }
 139
 140 sub write {
 141   my $me = __FILE__;
 142   require IO::File;
 143   require Data::Dumper;
 144
 145   my $mode_orig = (stat $me)[2] & 07777;
 146   chmod($mode_orig | 0222, $me); # Make it writeable
 147   my $fh = IO::File->new($me, 'r+') or die "Can't rewrite $me: $!";
 148   seek($fh, 0, 0);
 149   while (<$fh>) {
 150     last if /^__DATA__$/;
 151   }
 152   die "Couldn't find __DATA__ token in $me" if eof($fh);
 153
 154   local $Data::Dumper::Terse = 1;
 155   seek($fh, tell($fh), 0);
 156   $fh->print( Data::Dumper::Dumper([$config, $features, $auto_features]) );
 157   truncate($fh, tell($fh));
 158   $fh->close;
 159
 160   chmod($mode_orig, $me)
 161     or warn "Couldn't restore permissions on $me: $!";
 162 }
 163
 164 sub feature {
 165   my ($package, $key) = @_;
 166   return $features->{$key} if exists $features->{$key};
 167
 168   my $info = $auto_features->{$key} or return 0;
 169
 170   # Under perl 5.005, each(%%$foo) isn't working correctly when $foo
 171   # was reanimated with Data::Dumper and eval().  Not sure why, but
 172   # copying to a new hash seems to solve it.
 173   my %%info = %%$info;
 174
 175   require Module::Build;  # XXX should get rid of this
 176   while (my ($type, $prereqs) = each %%info) {
 177     next if $type eq 'description' || $type eq 'recommends';
 178
 179     my %%p = %%$prereqs;  # Ditto here.
 180     while (my ($modname, $spec) = each %%p) {
 181       my $status = Module::Build->check_installed_status($modname, $spec);
 182       if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
 183     }
 184   }
 185   return 1;
 186 }
 187
 188 EOF
 189
 190   my ($module_name, $notes_name) = ($args{module}, $args{config_module});
 191   printf $fh <<"EOF", $notes_name, $module_name;
 192
 193 =head1 NAME
 194
 195 $notes_name - Configuration for $module_name
 196
 197
 198 =head1 SYNOPSIS
 199
 200   use $notes_name;
 201   \$value = $notes_name->config('foo');
 202   \$value = $notes_name->feature('bar');
 203
 204   \@names = $notes_name->config_names;
 205   \@names = $notes_name->feature_names;
 206
 207   $notes_name->set_config(foo => \$new_value);
 208   $notes_name->set_feature(bar => \$new_value);
 209   $notes_name->write;  # Save changes
 210
 211
 212 =head1 DESCRIPTION
 213
 214 This module holds the configuration data for the C<$module_name>
 215 module.  It also provides a programmatic interface for getting or
 216 setting that configuration data.  Note that in order to actually make
 217 changes, you'll have to have write access to the C<$notes_name>
 218 module, and you should attempt to understand the repercussions of your
 219 actions.
 220
 221
 222 =head1 METHODS
 223
 224 =over 4
 225
 226 =item config(\$name)
 227
 228 Given a string argument, returns the value of the configuration item
 229 by that name, or C<undef> if no such item exists.
 230
 231 =item feature(\$name)
 232
 233 Given a string argument, returns the value of the feature by that
 234 name, or C<undef> if no such feature exists.
 235
 236 =item set_config(\$name, \$value)
 237
 238 Sets the configuration item with the given name to the given value.
 239 The value may be any Perl scalar that will serialize correctly using
 240 C<Data::Dumper>.  This includes references, objects (usually), and
 241 complex data structures.  It probably does not include transient
 242 things like filehandles or sockets.
 243
 244 =item set_feature(\$name, \$value)
 245
 246 Sets the feature with the given name to the given boolean value.  The
 247 value will be converted to 0 or 1 automatically.
 248
 249 =item config_names()
 250
 251 Returns a list of all the names of config items currently defined in
 252 C<$notes_name>, or in scalar context the number of items.
 253
 254 =item feature_names()
 255
 256 Returns a list of all the names of features currently defined in
 257 C<$notes_name>, or in scalar context the number of features.
 258
 259 =item auto_feature_names()
 260
 261 Returns a list of all the names of features whose availability is
 262 dynamically determined, or in scalar context the number of such
 263 features.  Does not include such features that have later been set to
 264 a fixed value.
 265
 266 =item write()
 267
 268 Commits any changes from C<set_config()> and C<set_feature()> to disk.
 269 Requires write access to the C<$notes_name> module.
 270
 271 =back
 272
 273
 274 =head1 AUTHOR
 275
 276 C<$notes_name> was automatically created using C<Module::Build>.
 277 C<Module::Build> was written by Ken Williams, but he holds no
 278 authorship claim or copyright claim to the contents of C<$notes_name>.
 279
 280 =cut
 281
 282 __DATA__
 283
 284 EOF
 285
 286   local $Data::Dumper::Terse = 1;
 287   print $fh Data::Dumper::Dumper([$args{config_data}, $args{feature}, $args{auto_features}]);
 288 }
 289
 290 1;