git.maemo.org Git - dh-make-perl/blob - dev/i386/libmodule-build-perl/libmodule-build-perl-0.2808.01/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.2808_01';
   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     }
 190   }
 191   return 1;
 192 }
 193
 194 EOF
 195
 196   my ($module_name, $notes_name) = ($args{module}, $args{config_module});
 197   printf $fh <<"EOF", $notes_name, $module_name;
 198
 199 =head1 NAME
 200
 201 $notes_name - Configuration for $module_name
 202
 203
 204 =head1 SYNOPSIS
 205
 206   use $notes_name;
 207   \$value = $notes_name->config('foo');
 208   \$value = $notes_name->feature('bar');
 209
 210   \@names = $notes_name->config_names;
 211   \@names = $notes_name->feature_names;
 212
 213   $notes_name->set_config(foo => \$new_value);
 214   $notes_name->set_feature(bar => \$new_value);
 215   $notes_name->write;  # Save changes
 216
 217
 218 =head1 DESCRIPTION
 219
 220 This module holds the configuration data for the C<$module_name>
 221 module.  It also provides a programmatic interface for getting or
 222 setting that configuration data.  Note that in order to actually make
 223 changes, you'll have to have write access to the C<$notes_name>
 224 module, and you should attempt to understand the repercussions of your
 225 actions.
 226
 227
 228 =head1 METHODS
 229
 230 =over 4
 231
 232 =item config(\$name)
 233
 234 Given a string argument, returns the value of the configuration item
 235 by that name, or C<undef> if no such item exists.
 236
 237 =item feature(\$name)
 238
 239 Given a string argument, returns the value of the feature by that
 240 name, or C<undef> if no such feature exists.
 241
 242 =item set_config(\$name, \$value)
 243
 244 Sets the configuration item with the given name to the given value.
 245 The value may be any Perl scalar that will serialize correctly using
 246 C<Data::Dumper>.  This includes references, objects (usually), and
 247 complex data structures.  It probably does not include transient
 248 things like filehandles or sockets.
 249
 250 =item set_feature(\$name, \$value)
 251
 252 Sets the feature with the given name to the given boolean value.  The
 253 value will be converted to 0 or 1 automatically.
 254
 255 =item config_names()
 256
 257 Returns a list of all the names of config items currently defined in
 258 C<$notes_name>, or in scalar context the number of items.
 259
 260 =item feature_names()
 261
 262 Returns a list of all the names of features currently defined in
 263 C<$notes_name>, or in scalar context the number of features.
 264
 265 =item auto_feature_names()
 266
 267 Returns a list of all the names of features whose availability is
 268 dynamically determined, or in scalar context the number of such
 269 features.  Does not include such features that have later been set to
 270 a fixed value.
 271
 272 =item write()
 273
 274 Commits any changes from C<set_config()> and C<set_feature()> to disk.
 275 Requires write access to the C<$notes_name> module.
 276
 277 =back
 278
 279
 280 =head1 AUTHOR
 281
 282 C<$notes_name> was automatically created using C<Module::Build>.
 283 C<Module::Build> was written by Ken Williams, but he holds no
 284 authorship claim or copyright claim to the contents of C<$notes_name>.
 285
 286 =cut
 287
 288 __DATA__
 289
 290 EOF
 291
 292   print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
 293 }
 294
 295 1;