"Fossies" - the Fresh Open Source Software Archive

Member "Module-Build-0.4224/lib/Module/Build/Notes.pm" (30 May 2017, 8312 Bytes) of package /linux/privat/Module-Build-0.4224.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Notes.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 0.4222_vs_0.4224.

    1 package Module::Build::Notes;
    2 
    3 # A class for persistent hashes
    4 
    5 use strict;
    6 use warnings;
    7 our $VERSION = '0.4224';
    8 $VERSION = eval $VERSION;
    9 use Data::Dumper;
   10 use Module::Build::Dumper;
   11 
   12 sub new {
   13   my ($class, %args) = @_;
   14   my $file = delete $args{file} or die "Missing required parameter 'file' to new()";
   15   my $self = bless {
   16             disk => {},
   17             new  => {},
   18             file => $file,
   19             %args,
   20            }, $class;
   21 }
   22 
   23 sub restore {
   24   my $self = shift;
   25 
   26   open(my $fh, '<', $self->{file}) or die "Can't read $self->{file}: $!";
   27   $self->{disk} = eval do {local $/; <$fh>};
   28   die $@ if $@;
   29   close $fh;
   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   open(my $fh, '>', $file) or die "Can't create '$file': $!";
  111   print {$fh} Module::Build::Dumper->_data_dump($data);
  112   close $fh;
  113 }
  114 
  115 my $orig_template = do { local $/; <DATA> };
  116 close DATA;
  117 
  118 sub write_config_data {
  119   my ($self, %args) = @_;
  120 
  121   my $template = $orig_template;
  122   $template =~ s/NOTES_NAME/$args{config_module}/g;
  123   $template =~ s/MODULE_NAME/$args{module}/g;
  124   $template =~ s/=begin private\n//;
  125   $template =~ s/=end private/=cut/;
  126 
  127   # strip out private POD markers we use to keep pod from being
  128   # recognized for *this* source file
  129   $template =~ s{$_\n}{} for '=begin private', '=end private';
  130 
  131   open(my $fh, '>', $args{file}) or die "Can't create '$args{file}': $!";
  132   print {$fh} $template;
  133   print {$fh} "\n__DATA__\n";
  134   print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
  135   close $fh;
  136 }
  137 
  138 1;
  139 
  140 
  141 =head1 NAME
  142 
  143 Module::Build::Notes - Create persistent distribution configuration modules
  144 
  145 =head1 DESCRIPTION
  146 
  147 This module is used internally by Module::Build to create persistent
  148 configuration files that can be installed with a distribution.  See
  149 L<Module::Build::ConfigData> for an example.
  150 
  151 =head1 AUTHOR
  152 
  153 Ken Williams <kwilliams@cpan.org>
  154 
  155 =head1 COPYRIGHT
  156 
  157 Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
  158 
  159 This library is free software; you can redistribute it and/or
  160 modify it under the same terms as Perl itself.
  161 
  162 =head1 SEE ALSO
  163 
  164 perl(1), L<Module::Build>(3)
  165 
  166 =cut
  167 
  168 __DATA__
  169 package NOTES_NAME;
  170 use strict;
  171 my $arrayref = eval do {local $/; <DATA>}
  172   or die "Couldn't load ConfigData data: $@";
  173 close DATA;
  174 my ($config, $features, $auto_features) = @$arrayref;
  175 
  176 sub config { $config->{$_[1]} }
  177 
  178 sub set_config { $config->{$_[1]} = $_[2] }
  179 sub set_feature { $features->{$_[1]} = 0+!!$_[2] }  # Constrain to 1 or 0
  180 
  181 sub auto_feature_names { sort grep !exists $features->{$_}, keys %$auto_features }
  182 
  183 sub feature_names {
  184   my @features = (sort keys %$features, auto_feature_names());
  185   @features;
  186 }
  187 
  188 sub config_names  { sort keys %$config }
  189 
  190 sub write {
  191   my $me = __FILE__;
  192 
  193   # Can't use Module::Build::Dumper here because M::B is only a
  194   # build-time prereq of this module
  195   require Data::Dumper;
  196 
  197   my $mode_orig = (stat $me)[2] & 07777;
  198   chmod($mode_orig | 0222, $me); # Make it writeable
  199   open(my $fh, '+<', $me) 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 
  206   seek($fh, tell($fh), 0);
  207   my $data = [$config, $features, $auto_features];
  208   print($fh 'do{ my '
  209           . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
  210           . '$x; }' );
  211   truncate($fh, tell($fh));
  212   close $fh;
  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};
  221 
  222   my $info = $auto_features->{$key} or return 0;
  223 
  224   require Module::Build;  # XXX should get rid of this
  225   foreach my $type (sort keys %$info) {
  226     my $prereqs = $info->{$type};
  227     next if $type eq 'description' || $type eq 'recommends';
  228 
  229     foreach my $modname (sort keys %$prereqs) {
  230       my $status = Module::Build->check_installed_status($modname, $prereqs->{$modname});
  231       if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
  232       if ( ! eval "require $modname; 1" ) { return 0; }
  233     }
  234   }
  235   return 1;
  236 }
  237 
  238 =begin private
  239 
  240 =head1 NAME
  241 
  242 NOTES_NAME - Configuration for MODULE_NAME
  243 
  244 =head1 SYNOPSIS
  245 
  246   use NOTES_NAME;
  247   $value = NOTES_NAME->config('foo');
  248   $value = NOTES_NAME->feature('bar');
  249 
  250   @names = NOTES_NAME->config_names;
  251   @names = NOTES_NAME->feature_names;
  252 
  253   NOTES_NAME->set_config(foo => $new_value);
  254   NOTES_NAME->set_feature(bar => $new_value);
  255   NOTES_NAME->write;  # Save changes
  256 
  257 
  258 =head1 DESCRIPTION
  259 
  260 This module holds the configuration data for the C<MODULE_NAME>
  261 module.  It also provides a programmatic interface for getting or
  262 setting that configuration data.  Note that in order to actually make
  263 changes, you'll have to have write access to the C<NOTES_NAME>
  264 module, and you should attempt to understand the repercussions of your
  265 actions.
  266 
  267 
  268 =head1 METHODS
  269 
  270 =over 4
  271 
  272 =item config($name)
  273 
  274 Given a string argument, returns the value of the configuration item
  275 by that name, or C<undef> if no such item exists.
  276 
  277 =item feature($name)
  278 
  279 Given a string argument, returns the value of the feature by that
  280 name, or C<undef> if no such feature exists.
  281 
  282 =item set_config($name, $value)
  283 
  284 Sets the configuration item with the given name to the given value.
  285 The value may be any Perl scalar that will serialize correctly using
  286 C<Data::Dumper>.  This includes references, objects (usually), and
  287 complex data structures.  It probably does not include transient
  288 things like filehandles or sockets.
  289 
  290 =item set_feature($name, $value)
  291 
  292 Sets the feature with the given name to the given boolean value.  The
  293 value will be converted to 0 or 1 automatically.
  294 
  295 =item config_names()
  296 
  297 Returns a list of all the names of config items currently defined in
  298 C<NOTES_NAME>, or in scalar context the number of items.
  299 
  300 =item feature_names()
  301 
  302 Returns a list of all the names of features currently defined in
  303 C<NOTES_NAME>, or in scalar context the number of features.
  304 
  305 =item auto_feature_names()
  306 
  307 Returns a list of all the names of features whose availability is
  308 dynamically determined, or in scalar context the number of such
  309 features.  Does not include such features that have later been set to
  310 a fixed value.
  311 
  312 =item write()
  313 
  314 Commits any changes from C<set_config()> and C<set_feature()> to disk.
  315 Requires write access to the C<NOTES_NAME> module.
  316 
  317 =back
  318 
  319 
  320 =head1 AUTHOR
  321 
  322 C<NOTES_NAME> was automatically created using C<Module::Build>.
  323 C<Module::Build> was written by Ken Williams, but he holds no
  324 authorship claim or copyright claim to the contents of C<NOTES_NAME>.
  325 
  326 =end private
  327