[Summary view] [Print] [Text view]

   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;