File Coverage

blib/lib/Module/Build/Notes.pm

Criterion	Covered	Total	%
statement	91	91	100.0
branch	30	38	78.9
condition	13	20	65.0
subroutine	14	14	100.0
pod	1	8	12.5
total	149	171	87.1

package Module::Build::Notes;

# A class for persistent hashes

use strict;
use warnings;
our $VERSION = '0.42_33';
$VERSION = eval $VERSION;
use Data::Dumper;
use Module::Build::Dumper;

sub new {
  my ($class, %args) = @_;
  my $file = delete $args{file} or die "Missing required parameter 'file' to new()";
  my $self = bless {
		    disk => {},
		    new  => {},
		    file => $file,
		    %args,
		   }, $class;
}

sub restore {
  my $self = shift;

  open(my $fh, '<', $self->{file}) or die "Can't read $self->{file}: $!";
  $self->{disk} = eval do {local $/; <$fh>};
  die $@ if $@;
  close $fh;
  $self->{new} = {};
}

sub access {
  my $self = shift;
  return $self->read() unless @_;

  my $key = shift;
  return $self->read($key) unless @_;

  my $value = shift;
  $self->write({ $key => $value });
  return $self->read($key);
}

sub has_data {
  my $self = shift;
  return keys %{$self->read()} > 0;
}

sub exists {
  my ($self, $key) = @_;
  return exists($self->{new}{$key}) || exists($self->{disk}{$key});
}

sub read {
  my $self = shift;

  if (@_) {
    # Return 1 key as a scalar
    my $key = shift;
    return $self->{new}{$key} if exists $self->{new}{$key};
    return $self->{disk}{$key};
  }

  # Return all data
  my $out = (keys %{$self->{new}}
	     ? {%{$self->{disk}}, %{$self->{new}}}
	     : $self->{disk});
  return wantarray ? %$out : $out;
}

sub _same {
  my ($self, $x, $y) = @_;
  return 1 if !defined($x) and !defined($y);
  return 0 if !defined($x) or  !defined($y);
  return $x eq $y;
}

sub write {
  my ($self, $href) = @_;
  $href ||= {};

  @{$self->{new}}{ keys %$href } = values %$href;  # Merge

  # Do some optimization to avoid unnecessary writes
  foreach my $key (keys %{ $self->{new} }) {
    next if ref $self->{new}{$key};
    next if ref $self->{disk}{$key} or !exists $self->{disk}{$key};
    delete $self->{new}{$key} if $self->_same($self->{new}{$key}, $self->{disk}{$key});
  }

  if (my $file = $self->{file}) {
    my ($vol, $dir, $base) = File::Spec->splitpath($file);
    $dir = File::Spec->catpath($vol, $dir, '');
    return unless -e $dir && -d $dir;  # The user needs to arrange for this

    return if -e $file and !keys %{ $self->{new} };  # Nothing to do

    @{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}};  # Merge
    $self->_dump($file, $self->{disk});

    $self->{new} = {};
  }
  return $self->read;
}

sub _dump {
  my ($self, $file, $data) = @_;

  open(my $fh, '>', $file) or die "Can't create '$file': $!";
  print {$fh} Module::Build::Dumper->_data_dump($data);
  close $fh;
}

my $orig_template = do { local $/;  };
close DATA;

sub write_config_data {
  my ($self, %args) = @_;

  my $template = $orig_template;
  $template =~ s/NOTES_NAME/$args{config_module}/g;
  $template =~ s/MODULE_NAME/$args{module}/g;
  $template =~ s/=begin private\n//;
  $template =~ s/=end private/=cut/;

  # strip out private POD markers we use to keep pod from being
  # recognized for *this* source file
  $template =~ s{$_\n}{} for '=begin private', '=end private';

  open(my $fh, '>', $args{file}) or die "Can't create '$args{file}': $!";
  print {$fh} $template;
  print {$fh} "\n__DATA__\n";
  print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
  close $fh;
}

1;


=head1 NAME

Module::Build::Notes - Create persistent distribution configuration modules

=head1 DESCRIPTION

This module is used internally by Module::Build to create persistent
configuration files that can be installed with a distribution.  See
L for an example.

=head1 AUTHOR

Ken Williams

=head1 COPYRIGHT

Copyright (c) 2001-2006 Ken Williams.  All rights reserved.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

perl(1), L(3)

=cut

__DATA__