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.3603';
   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