PAR::Repository - Create and modify PAR repositories

  # Usually, you want to use the 'parrepo' script which comes with
  # this distribution.
  use PAR::Repository;

  my $repo = PAR::Repository->new( path => '/path/to/repository' );
  # creates a new repository if it doesn't exist, opens it if it
  # does exist.

  $repo->inject(
    file => 'Foo-Bar-0.01-x86_64-linux-gnu-thread-multi-5.8.7.par'
  );
  $repo->remove(
    file => '...'
  );
  $repo->query_module(regex => 'Foo::Bar');

  0 => Non-fatal errors.
  1 => Short status messages.
  2 => Method entry messages.-
  3 => Full debug output.

package PAR::Repository;

use 5.006;
use strict;
use warnings;

use Carp qw/croak/;
use File::Spec::Functions qw/catfile catdir splitpath/;
use File::Path qw/mkpath/;
use PAR::Dist qw//;
use YAML::Syck qw//;
use File::Copy qw//;
use Cwd qw//;
use Archive::Zip qw//;
use File::Temp qw//;
use version qw//;
use PAR::Indexer qw//;

use PAR::Repository::Zip;
use PAR::Repository::DBM;
use PAR::Repository::Query;
our @ISA = qw(
  PAR::Repository::Zip
  PAR::Repository::DBM
  PAR::Repository::Query
);

use constant REPOSITORY_INFO_FILE => 'repository_info.yml';

our $VERSION = '0.20';
our $VERBOSE = 0;

# does the running platform have symlinks?
our $Supports_Symlinks =
  exists($ENV{PAR_REPOSITORY_SYMLINK_SUPPORT})
  ? $ENV{PAR_REPOSITORY_SYMLINK_SUPPORT}
  : eval { symlink("",""); 1 };

# template for a repository_info.yml file
our $Info_Template = {
    repository_version => $VERSION,
    # on platforms which don't have symlinks, fake them for new repositories!
    ($Supports_Symlinks ? () : (fake_symlinks => 1)),
};

# Hash of compatible PAR::Repository versions
our $Compatible_Versions = {
    $VERSION => 1,
    '0.19'=> 1,
    '0.18_01'=> 1,
    '0.17_01'=> 1,
    '0.17'=> 1,
    '0.16_02' => 1,
    '0.16_01' => 1,
    '0.16' => 1,
    '0.15' => 1,
    '0.14' => 1,
    '0.13' => 1,
    '0.12' => 1,
    '0.11' => 1,
    '0.10' => 1,
    '0.03' => 1,
    '0.02' => 1,
};

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;

  croak(__PACKAGE__."->new() takes an even number of arguments.")
    if @_ % 2;
  my %args = @_;

  croak(__PACKAGE__."->new() needs a 'path' argument.")
    if not defined $args{path};

  my $path = $args{path};
  my $self = bless {
    path => $path,

    # The tied dbm hashes
    modules_hash      => undef,
    symlinks_hash     => undef,
    scripts_hash      => undef,
    dependencies_hash => undef,

    # The temp dbm files on disk
    modules_dbm_temp_file      => undef,
    symlinks_dbm_temp_file     => undef,
    scripts_dbm_temp_file      => undef,
    dependencies_dbm_temp_file => undef,

    # The YAML info as Perl data structure
    info => undef,
  } => $class;

  $self->verbose(2, "Created new repository object in path '$path'");

  # check that the repository exists or create it.	
  my $mod_dbm   = catfile($path, PAR::Repository::DBM::MODULES_DBM_FILE());
  my $sym_dbm   = catfile($path, PAR::Repository::DBM::SYMLINKS_DBM_FILE());
  my $scr_dbm   = catfile($path, PAR::Repository::DBM::SCRIPTS_DBM_FILE());
  my $dep_dbm   = catfile($path, PAR::Repository::DBM::DEPENDENCIES_DBM_FILE());
  my $info_file = catfile($path, PAR::Repository::REPOSITORY_INFO_FILE());

  if (-d $path
      and -f $mod_dbm.'.zip' and -f $sym_dbm.'.zip'
      and -f $info_file ) {
    # everything is in place. good.
    $self->verbose(3, "Repository exists");

    # load repository info
    $self->{info} = YAML::Syck::LoadFile($info_file);
    if ( not defined $self->{info}
         or not exists $self->{info}{repository_version} ) {
      croak("Repository exists, but it does not contain a valid repository_info.yml file.");
    }
    elsif ( not exists $Compatible_Versions->{$self->{info}{repository_version}} ) {
      croak("Repository exists, but it was created with an incompatible version of PAR::Repository (".$self->{info}{repository_version}.")");
    }
    # the following is a special case because the "incompatible changes
    # with every "\d+.\d" release" rule was introduced in 0.10
    elsif ( $Compatible_Versions->{$self->{info}{repository_version}} eq '0.03' ) {
      $self->_update_info_version or return ();
      $self->verbose(3, "Updated repository version");
    }

    if ($args{convert_symlinks}) {
      $self->_convert_symlinks();
    }

    if (!$Supports_Symlinks and !$self->{info}{fake_symlinks}) {
      croak("Repository may use symlinks but your platform does not support them. "
           ."Use the convert_symlinks => 1 option to the PAR::Repository constructor "
           ."to convert the repository to one which does not use symbolic links.");
    }

    $self->verbose(3, "Opened repository successfully");

    # Generate scripts db and upgrade repository version
    # if the scripts db doesn't exist.
    if (not -f $scr_dbm.'.zip') {
      $self->verbose(1, "Upgrading repository version to $VERSION");
      $self->_update_info_version or return ();
      $self->verbose(3, "Creating scripts database");
      $self->_create_dbm($scr_dbm.'.zip');
    }

    # Generate deps db and upgrade repository version
    # if the deps db doesn't exist.
    if (not -f $dep_dbm.'.zip') {
      $self->verbose(1, "Upgrading repository version to $VERSION");
      $self->_update_info_version or return ();
      $self->verbose(3, "Creating dependencies database");
      $self->_create_dbm($dep_dbm.'.zip');
    }

  } # end if everything is in place
  else {
    $self->verbose(3, "Repository doesn't exist yet");
    $self->_create_repository($path, !$Supports_Symlinks||$args{fake_symlinks});
  }

  return $self;
}

# creates a new repository
# called by the constructor if the directory doesn't exist
sub _create_repository {
  my $self = shift;
  my $path = shift;
  my $fake_symlinks = shift;

  if (-d $path) {
    croak("The repository path exists, but is not a repository. Delete it to create a new repository.");
  }
  mkpath([$path]);

  my $mod_dbm   = catfile($path, PAR::Repository::DBM::MODULES_DBM_FILE());
  my $sym_dbm   = catfile($path, PAR::Repository::DBM::SYMLINKS_DBM_FILE());
  my $scr_dbm   = catfile($path, PAR::Repository::DBM::SCRIPTS_DBM_FILE());
  my $dep_dbm   = catfile($path, PAR::Repository::DBM::DEPENDENCIES_DBM_FILE());
  my $info_file = catfile($path, PAR::Repository::REPOSITORY_INFO_FILE());

  $self->verbose(3, "Creating repository databases");
  foreach my $dbm ($mod_dbm, $sym_dbm, $scr_dbm, $dep_dbm) {
    $self->_create_dbm($dbm.'.zip');
  }

  my $info_copy = {%$Info_Template};
  $info_copy->{fake_symlinks} = 1 if $fake_symlinks;
  YAML::Syck::DumpFile($info_file, $info_copy);
  $self->{info} = YAML::Syck::LoadFile($info_file);
}

# converts all symlinks to files, sets {info}->{fake_symlinks},
# and saves it
# called by the constructor
sub _convert_symlinks {
  my $self = shift;
  $self->{error} = undef;
  $self->verbose(1, "Converting symlinks to files!");

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

  my $info_file = catfile($self->{path}, PAR::Repository::REPOSITORY_INFO_FILE());

  my ($symdbm, $temp_file) = $self->symlinks_dbm;
  while (my ($file, $symlinks) = each %$symdbm) {
    my ($distname, $distver, $arch, $perlver) = PAR::Dist::parse_dist_name($file);
    my $file_fullpath = File::Spec->catfile($arch, $perlver, $file);

    foreach my $symlink_file (@$symlinks) {
      my ($distname, $distver, $arch, $perlver) = PAR::Dist::parse_dist_name($symlink_file);
      my $symlink_file_fullpath = File::Spec->catfile($arch, $perlver, $symlink_file);
      # first unlink or else File::Copy may claim it can't copy because the files are
      # the same.
      (unlink( $symlink_file_fullpath ) and File::Copy::copy( $file_fullpath, $symlink_file_fullpath ))
        or chdir($old_dir),
        die "Error converting symlinks in repository to real files: Could not copy "
           ."'$file' to '$symlink_file'. Your repository may be in an inconsistent "
           ."state now. Reason: $!";
    }
  }
  chdir($old_dir);

  $self->{info}{fake_symlinks} = 1;
  YAML::Syck::DumpFile($info_file, $self->{info});
  $self->{info} = YAML::Syck::LoadFile($info_file);
  return 1;
}

sub inject {
  my $self = shift;
  croak(__PACKAGE__."->inject() takes an even number of arguments.")
    if @_ % 2;

  $self->verbose(2, "Entering inject()");

  my %args = @_;

  my $dfile = $args{file};
  croak(__PACKAGE__."->inject() needs a 'file' parameter.")
    if not defined $dfile;
  croak(__PACKAGE__."->inject(): Specified file '$dfile' does not exist.")
    if not -f $dfile;

  # determine the name of the target (in-repository) file
  my ($target_file, $distname, $distver, $arch, $perlver) = $self->_get_target_file('inject', \%args);

  $self->verbose(3, "Target file will be '$target_file'");

  # read META.yml from PAR archive
  my $meta = PAR::Dist::get_meta($dfile);
  my $meta_data;
  if (defined $meta) {
    $self->verbose(3, "We have a META.yml");
    $meta_data = YAML::Syck::Load($meta);
  }


  # Deterimine the packages in the distribution
  my $packages;
  if (!$args{ignore_provides} and defined $meta_data and exists $meta_data->{provides}) {
    # cool, we have a working META.yml with provides!
    $self->verbose(3, "... which has a 'provides' field");
    $packages = $meta_data->{provides};
  }
  else {
    # we need to do the scanning ourselves (damn)
    $self->verbose(3, "Need to scan for .pm files");
    $packages = PAR::Indexer::scan_par_for_packages($dfile);
  }

  if (not defined $packages) {
    # error scanning
    croak("Your PAR distribution is either invalid or doesn't contain any modules.");
  }

  # Determine dependencies as declared in META.yml
  my $dependencies;
  if (not $args{no_dependencies}) {
    $dependencies = PAR::Indexer::dependencies_from_meta_yml($meta_data);
  }
  # FIXME This is not the right way. There should be a dependency scanner, no?
  $dependencies = {} if not defined $dependencies;

  # determine any scripts to index
  my $scripts;
  if (not $args{no_scripts}) {
    $self->verbose(3, "Scanning par for scripts");
    $scripts = PAR::Indexer::scan_par_for_scripts($dfile);
  }


  # create path in repository
  my $destpath = catdir($arch, $perlver);
  $self->verbose(3, "Creating path in repository: '$destpath'");
  mkpath( catdir($self->{path}, $destpath) );

  # copy file over
  my $target_in_rep   =  catfile($destpath, $target_file);
  my $complete_target =  catdir($self->{path}, $target_in_rep);
  if (-f $complete_target or -l $complete_target) {
    # damn, we're overwriting an existing archive or symlink.
    if (not $args{overwrite}) {
      # don't overwrite
      $self->verbose(1, "Found existing file '$target_in_rep'. Not overwriting because 'overwrite' isn't set.");
      return undef;
    }
    elsif ($self->_is_symlink($target_file, switch_to_path => 1)) {
      $self->verbose(1, "Found existing symlink '$target_in_rep'. Overwriting because 'overwrite' is set.");
      $self->_remove_symlink(sym => $target_in_rep);
    }
    else {
      $self->verbose(1, "Found existing file '$target_in_rep'. Overwriting because 'overwrite' is set.");
      $self->remove(file => $target_in_rep);
    }
  }
  File::Copy::copy($dfile, $complete_target);


  # insert into modules dbm.
  $self->verbose(3, "Inserting packages into modules DBM");
  $self->_add_packages(packages => $packages, file => $target_file);


  # insert into scripts dbm.
  if (not $args{no_scripts}) {
    $self->verbose(3, "Inserting scripts into scripts DBM");
    $self->_add_scripts(scripts => $scripts, file => $target_file);
  }

  
  # insert into deps dbm
  if (not $args{no_dependencies}) {
    $self->verbose(3, "Inserting dependencies into dependencies DBM");
    $self->_add_dependencies(dependencies => $dependencies, file => $target_file);
  }

  my $is_any_arch = $args{any_arch} && !($arch eq 'any_arch');
  my $is_any_perl = $args{any_version} && !($arch eq 'any_version');

  # add symlinks
  $self->verbose(3, "Adding symlinks to symlinks DBM");

  if ($is_any_arch) {
    my $dir = catdir('any_arch', $perlver);
    mkpath(catdir($self->{path}, $dir));
    my $sym = join('-', $distname, $distver, 'any_arch', $perlver).'.par';
    my $success = $self->_add_symlink(
      file => $target_file,
      sym => $sym,
      overwrite => $args{overwrite},
    );
    # associate packages and scripts with symlink as well
    $self->_add_packages(packages => $packages, file => $sym)
      if $success;
    $self->_add_scripts(scripts => $scripts, file => $sym)
      if $success and not $args{no_scripts};
  }
  if ($is_any_perl) {
    my $dir = catdir($arch, 'any_version');
    mkpath(catdir($self->{path}, $dir));
    my $sym = join('-', $distname, $distver, $arch, 'any_version').'.par';
    my $success = $self->_add_symlink(
      file => $target_file,
      sym => $sym,
      overwrite => $args{overwrite},
    );
    # associate packages and scripts with symlink as well
    $self->_add_packages(packages => $packages, file => $sym)
      if $success;
    $self->_add_scripts(scripts => $scripts, file => $sym)
      if $success and not $args{no_scripts};
  }
  if ($is_any_arch and $is_any_perl) {
    my $dir = catdir('any_arch', 'any_version');
    mkpath(catdir($self->{path}, $dir));
    my $sym = join('-', $distname, $distver, 'any_arch', 'any_version').'.par';
    my $success = $self->_add_symlink(
      file => $target_file,
      sym => $sym,
      overwrite => $args{overwrite},
    );
    # associate packages and scripts with symlink as well
    $self->_add_packages(packages => $packages, file => $sym)
      if $success;
    $self->_add_scripts(scripts => $scripts, file => $sym)
      if $success and not $args{no_scripts};
  }

  $self->close_modules_dbm;
  $self->close_symlinks_dbm;
  $self->close_scripts_dbm;
  $self->close_dependencies_dbm;
  return 1;
}

# first argument is a path in the repository.
# expects to be called from within the main repository path
# or with the switch_to_path => 1 option.
# returns a boolean indicating whether a file is a symlink or
# not. Normally, this is just -l $file, but if fake_symlinks
# is in effect, the file will be a real file and we have to
# check the symlink dbm!
sub _is_symlink {
  my $self = shift;
  my $file = shift;
  $self->verbose(3, "Entering _is_symlink('$file')");
  my %args = @_;

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

  (undef, undef, $file) = File::Spec->splitpath($file);
  (undef, undef, my $filearch, my $filepver) = PAR::Dist::parse_dist_name($file);

  if ($self->{info}{fake_symlinks}) {
    $self->verbose(5, "In _is_symlink: fake_symlinks enabled.");
    my ($symh) = $self->symlinks_dbm;
    while (my ($dist, $symlinks) = each %$symh) {
      # otherwise, things might potentially blow up with strange directory
      # separators. This will need better consideration in the future.
      chdir($old_dir), return 1 if grep { $file eq $_ } @$symlinks;
    }
    chdir($old_dir);
    return();
  }
  else {
    $self->verbose(5, "In _is_symlink: fake_symlinks disabled.");
    my $f = File::Spec->catfile($filearch, $filepver, $file);
    my $link = -l $f;
    chdir($old_dir);
    return $link;
  }
}

sub remove {
  my $self = shift;
  croak(__PACKAGE__."->remove() takes an even number of arguments.")
    if @_ % 2;

  $self->verbose(2, "Entering remove()");

  my %args = @_;

#  my $dfile = $args{file};
#  croak(__PACKAGE__."->remove() needs a 'file' parameter.")
#    if not defined $dfile;
#  croak(__PACKAGE__."->remove(): Specified file '$dfile' does not exist.")
#    if not -f $dfile;

  # determine the name of the target (in-repository) file
  my ($target_file, $distname, $distver, $arch, $perlver) = $self->_get_target_file('remove', \%args);

  $self->verbose(3, "Target file for removal will be '$target_file'");

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

  my $complete_target = catfile( $arch, $perlver, $target_file );

  if (not -f $complete_target and not -l $complete_target) {
    # not in repo
    $self->verbose(1, "Target file is not in repository");
    chdir($old_dir);
    return ();
  }
  elsif ($self->_is_symlink($target_file)) {
    # target is a symlink, remove the link only.
    $self->verbose(1, "Target file is a symlink. Removing the symlink only");
    chdir($old_dir);
    my ($modh) = $self->modules_dbm;
    my ($scrh) = $self->scripts_dbm;
    if (not $self->_remove_files_from_db($modh, [$target_file])
        or not $self->_remove_files_from_db($scrh, [$target_file])
        or not $self->_remove_symlink(sym => $target_file) ) {
      $self->close_modules_dbm;
      $self->close_scripts_dbm;
      return();
    }
    else {
      $self->close_modules_dbm;
      $self->close_scripts_dbm;
      return 1;
    }
  }

  chdir($old_dir);

  # target is a file. remove file and its symlinks.

  my ($symh) = $self->symlinks_dbm;
  my ($modh) = $self->modules_dbm;
  my ($scrh) = $self->scripts_dbm;
  my ($deph) = $self->dependencies_dbm;

  # find links
  # Why so complicated? Because DBM::Deep has too much magic!
  my $links = exists($symh->{$target_file}) ? $symh->{$target_file} : [];
  if (not defined $links) {
    die "Found undefined value in symlinks DBM for file name '$target_file'! This is a regression!";
  }
  else {
    $links = [ map {$_} @$links ];
  }

  my @module_and_links = ($target_file);
  push @module_and_links, @$links;

  # remove mention of the distro and links
  # from modules and scripts dbs (This is slow!)
  $self->_remove_files_from_db($modh, \@module_and_links);
  $self->_remove_files_from_db($scrh, \@module_and_links);

  # remove dependencies
  if (exists $deph->{$target_file}) {
    delete $deph->{$target_file};
  }

  # remove links
  foreach my $link (@$links) {
    $self->_remove_symlink(sym => $link)
  }

  # remove the whole archive from the symlinks db
  if ( exists($symh->{$target_file})
       and ref($symh->{$target_file})
       and @{$symh->{$target_file}} == 0 ) {
    delete $symh->{$target_file};
  }

  # remove file
  $old_dir = Cwd::cwd();
  chdir($self->{path});
  unlink($complete_target)
    or die "Could not remove file '$complete_target' from repository. Current path is '".Cwd::cwd()."'";

  chdir($old_dir);
  $self->close_modules_dbm;
  $self->close_symlinks_dbm;
  $self->close_scripts_dbm;
  $self->close_dependencies_dbm;

  return 1;
}

sub verbose {
  my $self = shift;
  my $verbosity = shift;
  my $msg = shift;

  if ($PAR::Repository::VERBOSE >= 4) {
    my %call_info;
    @call_info{
      qw(pack file line sub has_args wantarray evaltext is_require)
    } = caller(0);
    warn "$msg at $call_info{file} line $call_info{line}\n";
  }
  elsif ($PAR::Repository::VERBOSE >= $verbosity) {
    print "$msg\n";
  }
  return;
}

sub _cmp_dist_versions {
  my $self = shift;
  my $f1 = shift;
  my $f2 = shift;

  (undef, my $dv1, undef, undef) = PAR::Dist::parse_dist_name($f1);
  (undef, my $dv2, undef, undef) = PAR::Dist::parse_dist_name($f2);

  if (not defined $dv1) {
    return 0 if not defined $dv2;
    return 1;
  }
  elsif (not defined $dv2) {
    return -1;
  }

  my $v1 = version->new($dv1);
  my $v2 = version->new($dv2);
  return($v1 <=> $v2);
}

sub _add_packages {
  my $self = shift;
  $self->verbose(2, "Entering _add_packages()");
  my %args = @_;
  my $packages = $args{packages};
  my $target_file = $args{file};

  my ($hash, $temp_file) = $self->modules_dbm;
  my %missing_version;
  my %seen_files; # if a version is not available, fall back to another version in the file IF it's a META style provides
  foreach my $pkgname (keys %$packages) {
    $hash->{$pkgname} = {} if not exists $hash->{$pkgname};
    my $this_pkg_dists = $hash->{$pkgname};
    
    if (!ref($packages->{$pkgname})) {
      # flat pkg => version
      $this_pkg_dists->{$target_file} = $packages->{$pkgname}||'0';
    }
    else {
      # nested META.yml style provides
      if (not exists $packages->{$pkgname}{version}) {
        $missing_version{$pkgname} = $packages->{$pkgname};
      }
      else {
        $this_pkg_dists->{$target_file} = $packages->{$pkgname}{version};
        $seen_files{ $packages->{$pkgname}{file} } = $packages->{$pkgname}{version}
          if defined $packages->{$pkgname}{file}
          and defined $packages->{$pkgname}{version};
      }
    }
  } # end foreach package

  # fill in the missing versions that might be resolved using the file matching
  # this is here since the ordering isn't defined
  foreach my $pkgname (keys %missing_version) {
    my $this_pkg_dists = $hash->{$pkgname};
    $this_pkg_dists->{$target_file} = $seen_files{ $missing_version{$pkgname}{file} }; # degrades to undef
  }

  return 1;
}

sub _add_scripts {
  my $self = shift;
  $self->verbose(2, "Entering _add_scripts()");
  my %args = @_;
  my $scripts = $args{scripts};
  my $target_file = $args{file};

  my ($hash) = $self->scripts_dbm;
  foreach my $scr (keys %$scripts) {
    $hash->{$scr} = {} if not exists $hash->{$scr};
    $hash->{$scr}{$target_file} = $scripts->{$scr}{version};
  }
  return 1;
}

sub _add_symlink {
  my $self = shift;
  my %args = @_;
  my $file = $args{file};
  my $sym = $args{sym};
  $self->verbose(2, "Entering _add_symlink, adding symlink '$sym' to '$file'");

  # We do not want any user defined directories.
  # Why? Because they would end up in the database with
  # system-specific path separators. BANG!
  (undef, undef, $file) = splitpath($file);
  (undef, undef, $sym)  = splitpath($sym);

  # get the directory in the repository.
  (undef, undef, my $filearch, my $filepver) = PAR::Dist::parse_dist_name($file);
  (undef, undef, my $symarch, my $sympver) = PAR::Dist::parse_dist_name($sym);
  my $filedir = catdir( $filearch, $filepver );
  my $symdir  = catdir( $symarch, $sympver );
  my $file_full = catfile( $filedir, $file );
  my $sym_full  = catfile( $symdir, $sym );

  my $overwrite = $args{overwrite};

  if (!$Supports_Symlinks and !$self->{info}{fake_symlinks}) {
    croak("Symlinks are not supported on this system! Try creating a repository "
         ."with the fake_symlinks option set or convert it by supplying the "
         ."convert_symlinks => 1 option to the PAR::Repository constructor.");
  }

  # get the symlinks dbm while in the old path
  my ($shash) = $self->symlinks_dbm;

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

  if ($self->_is_symlink($sym)) {
    $self->verbose(1, "Symlink '$sym' exists. Overwrite is set to ".($overwrite?1:0));
    chdir($old_dir), return undef if not $overwrite;
    $self->_remove_symlink(sym => $sym);
  }
  elsif (-f $sym_full) {
    $self->verbose(1, "Symlink '$sym' is a file. Not overwriting");
    chdir($old_dir), return undef;
    # Files always take precedence over symlinks.
  }

  if ($self->{info}{fake_symlinks}) {
    $self->verbose(1, "fake_symlinks is set. Copying file instead of linking");
    File::Copy::copy($file_full, $sym_full) or die $!;
  }
  else {
    my $source_file = catfile( File::Spec->updir, File::Spec->updir, $file_full );
    symlink($source_file, $sym_full)
      or die "Could not create symlink from (full repo paths) '$sym_full' to file '$source_file'";
  }

  $shash->{$file} = [] if not defined $shash->{$file};
  push @{$shash->{$file}}, $sym;

  chdir($old_dir);

  return 1;
}

sub _add_dependencies {
  my $self = shift;
  $self->verbose(2, "Entering _add_dependencies()");
  my %args = @_;
  my $distribution = $args{file};
  my $dependencies = $args{dependencies};
  return()
    if not defined $distribution
    or not defined $dependencies
    or not ref($dependencies) eq 'HASH'
    or keys(%$dependencies) == 0;

  my ($hash, $temp_file) = $self->dependencies_dbm;
  # FIXME: shouldn't really exist, no?
  my $dist_hash = $hash->{$distribution} ||= {};
  foreach my $dep_name (keys %$dependencies) {
    $dist_hash->{$dep_name} = $dependencies->{$dep_name};
    $dist_hash->{$dep_name} = 0 if not defined $dist_hash->{$dep_name};
  }
  return 1;
}

sub _update_info_version {
  my $self = shift;
  $self->verbose(2, "Entering _update_info_version");
  my $yaml = $self->{info} ||= {};
  $yaml->{repository_version} = $VERSION;
  my $info_file = catfile($self->{path}, PAR::Repository::REPOSITORY_INFO_FILE());
  unless (YAML::Syck::DumpFile($info_file, $yaml)) {
    croak("Could not write repository info YAML file to '$info_file'.");
  }
  return 1;
}

sub _remove_files_from_db {
  my $self = shift;
  my $db = shift;
  my $files = shift;

  $self->verbose(2, "Entering _remove_files_from_db('".join("', '",@$files)."'");

  my %files = map {($_ => undef)} @$files;
  my $deleted = 0;
  foreach my $namespace_or_script (keys %$db) {
    my $in_dists = $db->{$namespace_or_script};
    foreach my $distfile (keys %$in_dists) {
      if (exists $files{$distfile}) {
        $deleted++;
        delete $in_dists->{$distfile};
      }
    }
    # is empty? namespace no more in repository?
    if (keys(%$in_dists) == 0) {
      $deleted++;
      delete $db->{$namespace_or_script};
    }
  } # end for each namespace or script

  if ($deleted) {
    # recover disk space. See DBM::Deep docs.
    tied(%$db)->optimize();
  }

  return 1;
}

sub _remove_symlink {
  my $self = shift;
  my %args = @_;
  $self->verbose(2, "Entering _remove_symlink(sym => '".$args{sym}."')");

  my $sym = $args{sym};

  # We do not want any user defined directories.
  # Why? Because they would end up in the database with
  # system-specific path separators. BANG!
  (undef, undef, $sym)  = splitpath($sym);

  # get the directory in the repository.
  (undef, undef, my $symarch, my $sympver) = PAR::Dist::parse_dist_name($sym);
  my $symdir   = catdir( $symarch, $sympver );
  my $sym_full = catfile( $symdir, $sym );

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

  my ($shash) = $self->symlinks_dbm;

  if (not $self->_is_symlink($sym)) {
    $self->verbose(1, "Symlink '$sym' ('$sym_full' in the repository) doesn't exist or is not a symlink");
    chdir($old_dir);
    return ();
  }

  # remove references to that symlink from the db
  $self->verbose(3, "Removing all references to symlink from DBM");
  foreach my $file (keys %{$shash}) {
    my $syms = $shash->{$file};
    @$syms = grep {$_ ne $sym} @$syms;
    delete $shash->{$file}
      if @$syms == 0;
  }
  # recover disk space. See DBM::Deep docs.
  tied(%$shash)->optimize();

  $self->verbose(3, "Removing symlink '$sym'");
  unlink($sym_full) or (chdir($old_dir), return ());

  chdir($old_dir);

  return 1;
}


sub _get_target_file {
  my $self = shift;
  my $method = shift;
  my %args = %{shift()};

  $self->verbose(2, "Entering _get_target_file()");

  my ($distname, $distver, $arch, $perlver);

  if (grep {!defined($_)} @args{qw/distname distversion arch perlversion/}) {
    $self->verbose(3, "Did not get all distribution information as parameters. Parsing distribution name");
    my ($v, $p, $f) = splitpath($args{file});
    ($distname, $distver, $arch, $perlver) = PAR::Dist::parse_dist_name($f);
  }

  $distname = $args{distname} if defined $args{distname};
  $distver  = $args{distversion} if defined $args{distversion};
  $arch     = $args{arch} if defined $args{arch};
  $perlver  = $args{perlversion} if defined $args{perlversion};

  croak("Could not determine distribution name") if not defined $distname;
  croak("Could not determine distribution version") if not defined $distver;
  croak("Could not determine distribution architecture") if not defined $arch;
  croak("Could not determine distribution perl version") if not defined $perlver;
  my $target_file = join('-', $distname, $distver, $arch, $perlver).".par";
  $self->verbose(3, "Target file will be '$target_file'");

  return($target_file, $distname, $distver, $arch, $perlver);
}


sub DESTROY {
  my $self = shift;
  $self->verbose(2, "Entering DESTROY {}");

  $self->close_scripts_dbm;
  $self->close_modules_dbm;
  $self->close_symlinks_dbm;
  $self->close_dependencies_dbm;

  $self->update_dbm_checksums;
}


1;
__END__