local-lib5/lib/perl5/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;