package PAR::Repository::DBM;

use 5.006;
use strict;
use warnings;

use Carp qw/croak/;
use File::Spec::Functions qw/catfile splitpath/;
use DBM::Deep;
use Fcntl qw/:flock/;
use File::Copy qw();

our $VERSION = '0.20';
use constant 'MODULES_DBM_FILE'      => 'modules_dists.dbm';
use constant 'SYMLINKS_DBM_FILE'     => 'symlinks.dbm';
use constant 'SCRIPTS_DBM_FILE'      => 'scripts_dists.dbm';
use constant 'DEPENDENCIES_DBM_FILE' => 'dependencies.dbm';
use constant 'DBM_CHECKSUMS_FILE'    => 'dbm_checksums.txt';

=head1 NAME

PAR::Repository::DBM - DBM tools for PAR::Repository

=head1 SYNOPSIS

  use PAR::Repository;

=head1 DESCRIPTION

This module is for internal use only.
It contains code for accessing the DBM files of a
PAR repository.

=head2 EXPORT

None.

=head2 GLOBALS

This package has a few constants:

C<MODULES_DBM_FILE>, C<SYMLINKS_DBM_FILE>, and C<SCRIPTS_DBM_FILE>,
C<DEPENDENCIES_DBM_FILE>, and C<DBM_CHECKSUMS_FILE>.
They are accessible
as functions via C<PAR::Repository::DBM::...>. They indicate
the file names of the DBM databases and the DBM checksums file.

=head1 DATABASE STRUCTURE

This section outlines the structure of the DBM::Deep
database files used by PAR::Repository.

If you need to care about this, you should be a
PAR::Repository developer.

=head2 MODULES-DISTS DBM

The DBM file is a hash at top level.

It associates namespaces (keys) with a number of file names and
versions. The values of the top level hash are hashes again. These
contain file names as keys and corresponding versions as values.

Example:

  {
    'Math::Symbolic::Derivative' => {
      'Math-Symbolic-0.502-x86_64-linux-gnu-thread-multi-5.8.7.par' => '0.502',
      'Math-Symbolic-0.200-x86_64-linux-gnu-thread-multi-5.8.6.par' => '0.200',
    },
  }

This example means that the C<Math::Symbolic::Derivative> module can
be found in the two listed distribution files in the repository
with the listed versions. Note that the distribution version needs not
be the same as the B<module> version. The module version is the one
separately indicated.

=head2 SYMLINKS DBM

The DBM file is a hash at top level.

It associates real files in the repository (keys) with a number of
symbolic links.
The values of the top level hash are arrays of distribution file names
which are symlinks.

Example: (with some extra linebreaks to keep the text width down)

  {
    'Math-Symbolic-0.502-x86_64-linux-gnu-thread-multi-5.8.7.par'
       => [
            'Math-Symbolic-0.502-any_arch-5.8.7.par',
            'Math-Symbolic-0.502-x86_64-linux-gnu-thread-multi-'
            .'any_version.par',
            'Math-Symbolic-0.502-any_arch-any_version.par'
          ],
  }

In the example, the first file is the real file and the paths/file names
in the value array are the names of the symbolic links.

=head2 SCRIPTS-DISTS DBM

This DBM file is a hash at top level. It associates script (executable)
names with distributions much like the C<modules_dists.dbm> file.

Example:

  {
    'parrepo' => {
      'PAR-Repository-0.03-x86_64--5.8.7.par'        => '0.02',
      'PAR-Repository-0.02-any_arch-any_version.par' => '0.01',
    },
  }

=head2 DEPENDENCIES DBM

This DBM file stores distribution names and associates them with
names of modules it depends on and their minimum versions. It does
not differentiate between the various types of dependencies that
can be found in a CPAN C<META.yml> file.

Example:

 {
   'Distname-0.03-x86_64-any_version.par' => {
      'Module::It::Depends::On' => '1.00',
   },
 }

=head1 METHODS

Following is a list of class and instance methods.
(Instance methods until otherwise mentioned.)

There is no C<PAR::Repository::DBM> object.
L<PAR::Repository> inherits from this class.

=cut

=head2 modules_dbm

Opens the modules_dists.dbm.zip file in the repository and
returns a tied hash reference to that file. Second return value is the
file name.

If the file does not exist, it returns the empty list.

You should know what you are doing when you use this
method.

=cut

sub modules_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering modules_dbm()');

  if (defined $self->{modules_dbm_hash}) {
    return $self->{modules_dbm_hash};
  }

  my $old_dir = Cwd::cwd();
  chdir($self->{path});
  my $file = PAR::Repository::DBM::MODULES_DBM_FILE().'.zip';
  chdir($old_dir), return() if not -f $file;

  my ($hash, $tempfile) = $self->_open_dbm($file);
  chdir($old_dir), return() if not defined $hash;

  $self->{modules_dbm_hash} = $hash;
  $self->{modules_dbm_temp_file} = $tempfile;

  chdir($old_dir);

  return ($hash, $tempfile);
}


=head2 symlinks_dbm

Opens the symlinks.dbm.zip file in the repository and
returns a tied hash reference to that file. Second
return value is the file name.

If the file does not exist, it returns the empty list.

You should know what you are doing when you use this
method.

=cut

sub symlinks_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering symlinks_dbm()');

  if (defined $self->{symlinks_dbm_hash}) {
    return $self->{symlinks_dbm_hash};
  }

  my $old_dir = Cwd::cwd();
  chdir($self->{path});

  my $file = PAR::Repository::DBM::SYMLINKS_DBM_FILE().'.zip';

  chdir($old_dir), return() if not -f $file;

  my ($hash, $tempfile) = $self->_open_dbm($file);
  chdir($old_dir), return() if not defined $hash;

  $self->{symlinks_dbm_hash} = $hash;
  $self->{symlinks_dbm_temp_file} = $tempfile;

  chdir($old_dir);

  return($hash, $tempfile);
}

=head2 scripts_dbm

Opens the scripts_dists.dbm.zip file in the repository and
returns a tied hash reference to that file. Second return value is
the file name.

If the file does not exist, it returns the empty list.

You should know what you are doing when you use this
method.

=cut

sub scripts_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering scripts_dbm()');

  if (defined $self->{scripts_dbm_hash}) {
    return $self->{scripts_dbm_hash};
  }

  my $old_dir = Cwd::cwd();
  chdir($self->{path});
  my $file = PAR::Repository::DBM::SCRIPTS_DBM_FILE().'.zip';
  chdir($old_dir), return() if not -f $file;

  my ($hash, $tempfile) = $self->_open_dbm($file);
  chdir($old_dir), return() if not defined $hash;

  $self->{scripts_dbm_hash} = $hash;
  $self->{scripts_dbm_temp_file} = $tempfile;

  chdir($old_dir);

  return($hash, $tempfile);
}

=head2 dependencies_dbm

Opens the dependencies.dbm.zip file in the repository and
returns a tied hash reference to that file. Second return value is the
file name.

If the file does not exist, it returns the empty list.

You should know what you are doing when you use this
method.

=cut

sub dependencies_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering dependencies_dbm()');

  if (defined $self->{dependencies_dbm_hash}) {
    return $self->{dependencies_dbm_hash};
  }

  my $old_dir = Cwd::cwd();
  chdir($self->{path});
  my $file = PAR::Repository::DBM::DEPENDENCIES_DBM_FILE().'.zip';
  chdir($old_dir), return() if not -f $file;

  my ($hash, $tempfile) = $self->_open_dbm($file);
  chdir($old_dir), return() if not defined $hash;

  $self->{dependencies_dbm_hash} = $hash;
  $self->{dependencies_dbm_temp_file} = $tempfile;

  chdir($old_dir);

  return ($hash, $tempfile);
}


=head2 close_modules_dbm

Closes the C<modules_dists.dbm> file committing any
changes and then zips it back into
C<modules_dists.dbm.zip>.

This is called when the object is destroyed.

=cut

sub close_modules_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering close_modules_dbm()');
  my $hash = $self->{modules_dbm_hash};
  return if not defined $hash;

  my $obj = tied($hash);
  $self->{modules_dbm_hash} = undef;
  undef $hash;
  undef $obj;

  $self->_zip_file(
      $self->{modules_dbm_temp_file},
      catfile($self->{path}, PAR::Repository::DBM::MODULES_DBM_FILE().'.zip'),
      PAR::Repository::DBM::MODULES_DBM_FILE(),
  );

  unlink $self->{modules_dbm_temp_file};
  $self->{modules_dbm_temp_file} = undef;

  return 1;
}


=head2 close_symlinks_dbm

The same as C<close_modules_dbm()> but for the
file C<symlinks.dbm.zip>.

Also called on object destruction.

=cut

sub close_symlinks_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering close_symlinks_dbm()');
  my $hash = $self->{symlinks_dbm_hash};
  return if not defined $hash;

  my $obj = tied($hash);
  $self->{symlinks_dbm_hash} = undef;
  undef $hash;
  undef $obj;

  $self->_zip_file(
      $self->{symlinks_dbm_temp_file},
      catfile($self->{path}, PAR::Repository::DBM::SYMLINKS_DBM_FILE().'.zip'),
      PAR::Repository::DBM::SYMLINKS_DBM_FILE(),
  );

  unlink $self->{symlinks_dbm_temp_file};
  $self->{symlinks_dbm_temp_file} = undef;

  return 1;
}

=head2 close_scripts_dbm

Closes the C<scripts_dists.dbm> file committing any
changes and then zips it back into
C<scripts_dists.dbm.zip>.

This is called when the object is destroyed.

=cut

sub close_scripts_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering close_scripts_dbm()');
  my $hash = $self->{scripts_dbm_hash};
  return if not defined $hash;

  my $obj = tied($hash);
  $self->{scripts_dbm_hash} = undef;
  undef $hash;
  undef $obj;

  $self->_zip_file(
      $self->{scripts_dbm_temp_file},
      catfile($self->{path}, PAR::Repository::DBM::SCRIPTS_DBM_FILE().'.zip'),
      PAR::Repository::DBM::SCRIPTS_DBM_FILE()
  );

  unlink $self->{scripts_dbm_temp_file};
  $self->{scripts_dbm_temp_file} = undef;

  return 1;
}


=head2 close_dependencies_dbm

Closes the C<dependencies.dbm> file committing any
changes and then zips it back into
C<dependencies.dbm.zip>.

This is called when the object is destroyed.

=cut

sub close_dependencies_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering close_dependencies_dbm()');
  my $hash = $self->{dependencies_dbm_hash};
  return if not defined $hash;

  my $obj = tied($hash);
  $self->{dependencies_dbm_hash} = undef;
  undef $hash;
  undef $obj;

  $self->_zip_file(
      $self->{dependencies_dbm_temp_file},
      catfile($self->{path}, PAR::Repository::DBM::DEPENDENCIES_DBM_FILE().'.zip'),
      PAR::Repository::DBM::DEPENDENCIES_DBM_FILE(),
  );

  unlink $self->{dependencies_dbm_temp_file};
  $self->{dependencies_dbm_temp_file} = undef;

  return 1;
}


=head2 update_dbm_checksums

Updates the DBM checksums file C<dbm_checksums.txt> with the
checksums of the currently existing zipped DBM files.

This is called when the L<PAR::Repository> object is destroyed.

Maintainer note: Very similar code lives in the
C<PAR::Repository::Client::DBM::_calculate_cache_local_checksums>
method. Keep in sync or refactor.

=cut

sub update_dbm_checksums {
  my $self = shift;
  $self->verbose(2, 'Entering update_dbm_checksums()');

  # find a working base64 MD5 implementation
  my $md5_function;
  eval { require Digest::MD5; $md5_function = \&Digest::MD5::md5_base64; };
  eval { require Digest::Perl::MD5;  $md5_function = \&Digest::Perl::MD5::md5_base64; } if $@;
  if ($@) {
    die "Could load neither Digest::MD5 nor Digest::Perl::MD5. Please upgrade your perl or install either of those modules.";
  }
  
  # Prepare temporary copy of the checkums file
  my ($tempfh, $tempfile) = File::Temp::tempfile(
      'temporary_dbm_checksum_XXXXX',
      UNLINK => 0,
      DIR    => File::Spec->tmpdir(),
  );
  print $tempfh <<'HERE';
# This checksums file has the format
# FILENAME BASE64_MD5_HASH
# where the file name and the MD5 hash are separated
# by a TAB character, not arbitrary whitespace!
HERE

  # calculate hashes and write them to the temp file
  foreach my $dbmfile (
      PAR::Repository::DBM::MODULES_DBM_FILE(),
      PAR::Repository::DBM::SCRIPTS_DBM_FILE(),
      PAR::Repository::DBM::SYMLINKS_DBM_FILE(),
      PAR::Repository::DBM::DEPENDENCIES_DBM_FILE(),
    ) {
    my $filepath = catfile($self->{path}, $dbmfile.'.zip');
    open my $fh, '<', $filepath or die "Could not open DBM file '$filepath' for reading: $!";
    flock $fh, LOCK_SH;
    local $/ = undef;
    my $hash = $md5_function->(<$fh>);
    close $fh;
    print $tempfh "$dbmfile.zip\t$hash\n";
  } # end foreach dbm files

  close $tempfh;
  # move temp file to destination
  my $target_file = catfile($self->{path}, PAR::Repository::DBM::DBM_CHECKSUMS_FILE());
  File::Copy::move($tempfile, $target_file)
    or die "Could not move checksums file '$tempfile' to '$target_file': $!";
  # FIXME, could this be done more user friendly? But somehow, the file ended up being 600 by default...
  chmod(0644, $target_file);

  return 1;
}


=head2 _open_dbm

Opens the zipped dbm file given as first argument.

This is B<only for internal use>.

=cut

sub _open_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering _open_dbm()');
  my $file = shift;
  my ($tempfh, $tempfile) = File::Temp::tempfile(
      'temporary_dbm_XXXXX',
      UNLINK => 0,
      DIR    => File::Spec->tmpdir(),
      EXLOCK => 0,
  );
  my ($v, $p, $f) = splitpath($file);
  $f =~ s/\.zip$//;
  $self->_unzip_file($file, $tempfile, $f) or return undef;
  my %hash;
  my $obj = tie %hash, "DBM::Deep", {
    file    => $tempfile,
    locking => 1,
  }; 

  return (\%hash, $tempfile);
}

=head2 _create_dbm

Creates a zipped dbm file given as first argument.

This is B<only for internal use>.

=cut

sub _create_dbm {
  my $self = shift;
  $self->verbose(2, 'Entering _create_dbm()');
  my $file = shift;
  $file .= '.zip' unless $file =~ /\.zip$/i;

  my ($tempfh, $tempfile) = File::Temp::tempfile(
      'temporary_dbm_XXXXX',
      UNLINK => 0,
      DIR    => File::Spec->tmpdir(),
      EXLOCK => 0,
  );
  {
    my %hash;
    my $obj = tie %hash, "DBM::Deep", {
      file    => $tempfile,
      locking => 1,
    }; 
  }

  my ($v, $p, $f) = splitpath($file);
  $f =~ s/\.zip$//i;
  $self->_zip_file($tempfile, $file, $f) or unlink($tempfile), return();

  unlink($tempfile);

  return 1;
}

1;
__END__

=head1 AUTHOR

Steffen ME<0xfc>ller, E<lt>smueller@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006-2009 by Steffen ME<0xfc>ller

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.6 or,
at your option, any later version of Perl 5 you may have available.

=cut