[p5sagit/p5-mst-13.2.git] / cpan / Module-Build / lib / Module / Build / Notes.pm

package Module::Build::Notes;

# A class for persistent hashes

use strict;
use vars qw($VERSION);
$VERSION = '0.3603';
$VERSION = eval $VERSION;
use Data::Dumper;
use IO::File;
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;

  my $fh = IO::File->new("< $self->{file}") or die "Can't read $self->{file}: $!";
  $self->{disk} = eval do {local $/; <$fh>};
  die $@ if $@;
  $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) = @_;

  my $fh = IO::File->new("> $file") or die "Can't create '$file': $!";
  print {$fh} Module::Build::Dumper->_data_dump($data);
}

my $orig_template = do { local $/; <DATA> };
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';

  my $fh = IO::File->new("> $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}]);

}

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<Module::Build::ConfigData> for an example.

=head1 AUTHOR

Ken Williams <kwilliams@cpan.org>

=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<Module::Build>(3)

=cut

__DATA__
package NOTES_NAME;
use strict;
my $arrayref = eval do {local $/; <DATA>}
  or die "Couldn't load ConfigData data: $@";
close DATA;
my ($config, $features, $auto_features) = @$arrayref;

sub config { $config->{$_[1]} }

sub set_config { $config->{$_[1]} = $_[2] }
sub set_feature { $features->{$_[1]} = 0+!!$_[2] }  # Constrain to 1 or 0

sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features }

sub feature_names {
  my @features = (keys %$features, auto_feature_names());
  @features;
}

sub config_names  { keys %$config }

sub write {
  my $me = __FILE__;
  require IO::File;

  # Can't use Module::Build::Dumper here because M::B is only a
  # build-time prereq of this module
  require Data::Dumper;

  my $mode_orig = (stat $me)[2] & 07777;
  chmod($mode_orig | 0222, $me); # Make it writeable
  my $fh = IO::File->new($me, 'r+') or die "Can't rewrite $me: $!";
  seek($fh, 0, 0);
  while (<$fh>) {
    last if /^__DATA__$/;
  }
  die "Couldn't find __DATA__ token in $me" if eof($fh);

  seek($fh, tell($fh), 0);
  my $data = [$config, $features, $auto_features];
  $fh->print( 'do{ my '
	      . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
	      . '$x; }' );
  truncate($fh, tell($fh));
  $fh->close;

  chmod($mode_orig, $me)
    or warn "Couldn't restore permissions on $me: $!";
}

sub feature {
  my ($package, $key) = @_;
  return $features->{$key} if exists $features->{$key};

  my $info = $auto_features->{$key} or return 0;

  # Under perl 5.005, each(%$foo) isn't working correctly when $foo
  # was reanimated with Data::Dumper and eval().  Not sure why, but
  # copying to a new hash seems to solve it.
  my %info = %$info;

  require Module::Build;  # XXX should get rid of this
  while (my ($type, $prereqs) = each %info) {
    next if $type eq 'description' || $type eq 'recommends';

    my %p = %$prereqs;  # Ditto here.
    while (my ($modname, $spec) = each %p) {
      my $status = Module::Build->check_installed_status($modname, $spec);
      if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
      if ( ! eval "require $modname; 1" ) { return 0; }
    }
  }
  return 1;
}

=begin private

=head1 NAME

NOTES_NAME - Configuration for MODULE_NAME

=head1 SYNOPSIS

  use NOTES_NAME;
  $value = NOTES_NAME->config('foo');
  $value = NOTES_NAME->feature('bar');

  @names = NOTES_NAME->config_names;
  @names = NOTES_NAME->feature_names;

  NOTES_NAME->set_config(foo => $new_value);
  NOTES_NAME->set_feature(bar => $new_value);
  NOTES_NAME->write;  # Save changes


=head1 DESCRIPTION

This module holds the configuration data for the C<MODULE_NAME>
module.  It also provides a programmatic interface for getting or
setting that configuration data.  Note that in order to actually make
changes, you'll have to have write access to the C<NOTES_NAME>
module, and you should attempt to understand the repercussions of your
actions.


=head1 METHODS

=over 4

=item config($name)

Given a string argument, returns the value of the configuration item
by that name, or C<undef> if no such item exists.

=item feature($name)

Given a string argument, returns the value of the feature by that
name, or C<undef> if no such feature exists.

=item set_config($name, $value)

Sets the configuration item with the given name to the given value.
The value may be any Perl scalar that will serialize correctly using
C<Data::Dumper>.  This includes references, objects (usually), and
complex data structures.  It probably does not include transient
things like filehandles or sockets.

=item set_feature($name, $value)

Sets the feature with the given name to the given boolean value.  The
value will be converted to 0 or 1 automatically.

=item config_names()

Returns a list of all the names of config items currently defined in
C<NOTES_NAME>, or in scalar context the number of items.

=item feature_names()

Returns a list of all the names of features currently defined in
C<NOTES_NAME>, or in scalar context the number of features.

=item auto_feature_names()

Returns a list of all the names of features whose availability is
dynamically determined, or in scalar context the number of such
features.  Does not include such features that have later been set to
a fixed value.

=item write()

Commits any changes from C<set_config()> and C<set_feature()> to disk.
Requires write access to the C<NOTES_NAME> module.

=back


=head1 AUTHOR

C<NOTES_NAME> was automatically created using C<Module::Build>.
C<Module::Build> was written by Ken Williams, but he holds no
authorship claim or copyright claim to the contents of C<NOTES_NAME>.

=end private
Commit	Line	Data
bb4e9162	1	package Module::Build::Notes;
	2
	3	# A class for persistent hashes
	4
	5	use strict;
7a827510	6	use vars qw($VERSION);
7dc9e1b4	7	$VERSION = '0.3603';
7a827510	8	$VERSION = eval $VERSION;
bb4e9162	9	use Data::Dumper;
bb4e9162	10	use IO::File;
7a827510	11	use Module::Build::Dumper;
bb4e9162	12
bb4e9162	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 @_;
53fc1c7e	36
bb4e9162	37	my $key = shift;
bb4e9162	38	return $self->read($key) unless @_;
53fc1c7e	39
bb4e9162	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	}
53fc1c7e	64
bb4e9162	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 \|\|= {};
53fc1c7e	82
bb4e9162	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	}
53fc1c7e	91
bb4e9162	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
53fc1c7e	98
53fc1c7e	99	@{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}}; # Merge
bb4e9162	100	$self->_dump($file, $self->{disk});
53fc1c7e	101
bb4e9162	102	$self->{new} = {};
	103	}
	104	return $self->read;
	105	}
	106
	107	sub _dump {
	108	my ($self, $file, $data) = @_;
53fc1c7e	109
bb4e9162	110	my $fh = IO::File->new("> $file") or die "Can't create '$file': $!";
7a827510	111	print {$fh} Module::Build::Dumper->_data_dump($data);
bb4e9162	112	}
bb4e9162	113
613f422f	114	my $orig_template = do { local $/; <DATA> };
	115	close DATA;
	116
bb4e9162	117	sub write_config_data {
	118	my ($self, %args) = @_;
	119
613f422f	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';
53fc1c7e	129
bb4e9162	130	my $fh = IO::File->new("> $args{file}") or die "Can't create '$args{file}': $!";
613f422f	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
bb4e9162	151
613f422f	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;
bb4e9162	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
613f422f	180	sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features }
bb4e9162	181
bb4e9162	182	sub feature_names {
613f422f	183	my @features = (keys %$features, auto_feature_names());
bb4e9162	184	@features;
	185	}
	186
613f422f	187	sub config_names { keys %$config }
bb4e9162	188
	189	sub write {
	190	my $me = __FILE__;
	191	require IO::File;
7a827510	192
	193	# Can't use Module::Build::Dumper here because M::B is only a
	194	# build-time prereq of this module
bb4e9162	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
bb4e9162	206	seek($fh, tell($fh), 0);
7a827510	207	my $data = [$config, $features, $auto_features];
	208	$fh->print( 'do{ my '
	209	. Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
	210	. '$x; }' );
bb4e9162	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};
53fc1c7e	221
bb4e9162	222	my $info = $auto_features->{$key} or return 0;
53fc1c7e	223
613f422f	224	# Under perl 5.005, each(%$foo) isn't working correctly when $foo
bb4e9162	225	# was reanimated with Data::Dumper and eval(). Not sure why, but
bb4e9162	226	# copying to a new hash seems to solve it.
613f422f	227	my %info = %$info;
53fc1c7e	228
bb4e9162	229	require Module::Build; # XXX should get rid of this
613f422f	230	while (my ($type, $prereqs) = each %info) {
bb4e9162	231	next if $type eq 'description' \|\| $type eq 'recommends';
53fc1c7e	232
613f422f	233	my %p = %$prereqs; # Ditto here.
613f422f	234	while (my ($modname, $spec) = each %p) {
bb4e9162	235	my $status = Module::Build->check_installed_status($modname, $spec);
bb4e9162	236	if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
23837600	237	if ( ! eval "require $modname; 1" ) { return 0; }
bb4e9162	238	}
	239	}
	240	return 1;
	241	}
	242
613f422f	243	=begin private
bb4e9162	244
	245	=head1 NAME
	246
613f422f	247	NOTES_NAME - Configuration for MODULE_NAME
bb4e9162	248
	249	=head1 SYNOPSIS
	250
613f422f	251	use NOTES_NAME;
	252	$value = NOTES_NAME->config('foo');
	253	$value = NOTES_NAME->feature('bar');
53fc1c7e	254
613f422f	255	@names = NOTES_NAME->config_names;
613f422f	256	@names = NOTES_NAME->feature_names;
53fc1c7e	257
613f422f	258	NOTES_NAME->set_config(foo => $new_value);
	259	NOTES_NAME->set_feature(bar => $new_value);
	260	NOTES_NAME->write; # Save changes
bb4e9162	261
	262
	263	=head1 DESCRIPTION
	264
613f422f	265	This module holds the configuration data for the C<MODULE_NAME>
bb4e9162	266	module. It also provides a programmatic interface for getting or
bb4e9162	267	setting that configuration data. Note that in order to actually make
613f422f	268	changes, you'll have to have write access to the C<NOTES_NAME>
bb4e9162	269	module, and you should attempt to understand the repercussions of your
	270	actions.
	271
	272
	273	=head1 METHODS
	274
	275	=over 4
	276
613f422f	277	=item config($name)
bb4e9162	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
613f422f	282	=item feature($name)
bb4e9162	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
613f422f	287	=item set_config($name, $value)
bb4e9162	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
613f422f	295	=item set_feature($name, $value)
bb4e9162	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
613f422f	303	C<NOTES_NAME>, or in scalar context the number of items.
bb4e9162	304
	305	=item feature_names()
	306
	307	Returns a list of all the names of features currently defined in
613f422f	308	C<NOTES_NAME>, or in scalar context the number of features.
bb4e9162	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.
613f422f	320	Requires write access to the C<NOTES_NAME> module.
bb4e9162	321
	322	=back
	323
	324
	325	=head1 AUTHOR
	326
613f422f	327	C<NOTES_NAME> was automatically created using C<Module::Build>.
bb4e9162	328	C<Module::Build> was written by Ken Williams, but he holds no
613f422f	329	authorship claim or copyright claim to the contents of C<NOTES_NAME>.
bb4e9162	330
613f422f	331	=end private
bb4e9162	332