Initial Commit

database/perl/vendor/lib/PAR/Repository/Client/DBM.pm

@@ -0,0 +1,501 @@
+package PAR::Repository::Client::DBM;
+
+use 5.006;
+use strict;
+use warnings;
+
+our $VERSION = '0.24';
+
+use Carp qw/croak/;
+
+=head1 NAME
+
+PAR::Repository::Client::DBM - Contains all the DBM access functions
+
+=head1 SYNOPSIS
+
+  use PAR::Repository::Client;
+
+=head1 DESCRIPTION
+
+This module implements access to the underlying DBMs.
+
+All of the methods described here shouldn't be used frivolously in user
+code even if some of them are part of the API and are guaranteed not
+to change.
+
+=cut
+
+
+=head2 need_dbm_update
+
+Takes one or no arguments. Without arguments, all DBM files are
+checked. With an argument, only the specified DBM file will be checked.
+
+Returns true if either one of the following conditions match:
+
+=over 2
+
+=item
+
+The repository does not support checksums.
+
+=item
+
+The checksums (and thus also the DBM files) haven't been
+downloaded yet.
+
+=item
+
+The local copies of the checksums do not match those of the repository.
+
+=back
+
+In cases two and three above, the return value is actually the hash
+reference of checksums that was fetched from the repository.
+
+Returns the empty list if the local checksums match those of the
+repository exactly.
+
+You don't usually need to call this directly. By default, DBM files
+are only fetched from the repository if necessary.
+
+=cut
+
+sub need_dbm_update {
+  my $self = shift;
+  $self->{error} = undef;
+
+  my $check_file = shift;
+  $check_file .= '.zip' if defined $check_file and not $check_file =~ /\.zip$/;
+
+  my $support = $self->{supports_checksums};
+  if (defined $support and not $support) {
+    return 1;
+  }
+
+  my $checksums = $self->_dbm_checksums();
+  $self->{last_checksums_refresh} = time() if $self->{checksums_timeout};
+
+  if (not defined $checksums) {
+    $self->{supports_checksums} = 0;
+    return 1;
+  }
+  else {
+    $self->{supports_checksums} = 1;
+  }
+
+  if (not defined $self->{checksums} or keys %{$self->{checksums}} == 0) {
+    # never fetched checksums before.
+    return $checksums;
+  }
+  else {
+    # we fetched checksums earlier, match them
+    my $local_checksums = $self->{checksums};
+    if (not defined $check_file) {
+      return $checksums if keys(%$local_checksums) != keys(%$checksums);
+      foreach my $file (keys %$checksums) {
+        return $checksums
+          if not exists $local_checksums->{$file}
+          or not $local_checksums->{$file} eq $checksums->{$file};
+      }
+    }
+    else {
+      return $checksums
+        if not exists $local_checksums->{$check_file}
+        or not exists $checksums->{$check_file} # shouldn't happen
+        or not $local_checksums->{$check_file} eq $checksums->{$check_file};
+    }
+    return();
+  }
+}
+
+
+=head2 modules_dbm
+
+Fetches the C<modules_dists.dbm> database from the repository,
+ties it to a L<DBM::Deep> object and returns a tied hash
+reference or the empty list on failure. Second return
+value is the name of the local temporary file.
+
+In case of failure, an error message is available via
+the C<error()> method.
+
+The method uses the C<_fetch_dbm_file()> method which must be
+implemented in a subclass such as L<PAR::Repository::Client::HTTP>.
+
+=cut
+
+sub modules_dbm {
+  my $self = shift;
+  return( $self->_get_a_dbm('modules', PAR::Repository::Client::MODULES_DBM_FILE()) );
+}
+
+
+=head2 scripts_dbm
+
+Fetches the C<scripts_dists.dbm> database from the repository,
+ties it to a L<DBM::Deep> object and returns a tied hash
+reference or the empty list on failure. Second return
+value is the name of the local temporary file.
+
+In case of failure, an error message is available via
+the C<error()> method.
+
+The method uses the C<_fetch_dbm_file()> method which must be
+implemented in a subclass such as L<PAR::Repository::Client::HTTP>.
+
+=cut
+
+sub scripts_dbm {
+  my $self = shift;
+  return( $self->_get_a_dbm('scripts', PAR::Repository::Client::SCRIPTS_DBM_FILE()) );
+}
+
+
+=head2 dependencies_dbm 
+
+Fetches the C<dependencies.dbm> database from the repository,
+ties it to a L<DBM::Deep> object and returns a tied hash
+reference or the empty list on failure. Second return
+value is the name of the local temporary file.
+
+In case of failure, an error message is available via
+the C<error()> method.
+
+The method uses the C<_fetch_dbm_file()> method which must be
+implemented in a subclass such as L<PAR::Repository::Client::HTTP>.
+
+=cut
+
+sub dependencies_dbm {
+  my $self = shift;
+  return( $self->_get_a_dbm('dependencies', PAR::Repository::Client::DEPENDENCIES_DBM_FILE()) );
+}
+
+
+=head2 close_modules_dbm
+
+Closes the C<modules_dists.dbm> file and does all necessary
+cleaning up.
+
+This is called when the object is destroyed.
+
+=cut
+
+sub close_modules_dbm {
+  my $self = shift;
+  my $hash = $self->{modules_dbm_hash};
+  return if not defined $hash;
+
+  my $obj = tied($hash);
+  $self->{modules_dbm_hash} = undef;
+  undef $hash;
+  undef $obj;
+
+  unlink $self->{modules_dbm_temp_file};
+  $self->{modules_dbm_temp_file} = undef;
+  if ($self->{checksums}) {
+    delete $self->{checksums}{PAR::Repository::Client::MODULES_DBM_FILE().".zip"};
+  }
+
+  return 1;
+}
+
+
+=head2 close_scripts_dbm
+
+Closes the C<scripts_dists.dbm> file and does all necessary
+cleaning up.
+
+This is called when the object is destroyed.
+
+=cut
+
+sub close_scripts_dbm {
+  my $self = shift;
+  my $hash = $self->{scripts_dbm_hash};
+  return if not defined $hash;
+
+  my $obj = tied($hash);
+  $self->{scripts_dbm_hash} = undef;
+  undef $hash;
+  undef $obj;
+
+  unlink $self->{scripts_dbm_temp_file};
+  $self->{scripts_dbm_temp_file} = undef;
+  if ($self->{checksums}) {
+    delete $self->{checksums}{PAR::Repository::Client::SCRIPTS_DBM_FILE().".zip"};
+  }
+
+  return 1;
+}
+
+
+=head2 close_dependencies_dbm
+
+Closes the C<dependencies.dbm> file and does all necessary
+cleaning up.
+
+This is called when the object is destroyed.
+
+=cut
+
+sub close_dependencies_dbm {
+  my $self = shift;
+  my $hash = $self->{dependencies_dbm_hash};
+  return if not defined $hash;
+
+  my $obj = tied($hash);
+  $self->{dependencies_dbm_hash} = undef;
+  undef $hash;
+  undef $obj;
+
+  unlink $self->{dependencies_dbm_temp_file};
+  $self->{dependencies_dbm_temp_file} = undef;
+  if ($self->{checksums}) {
+    delete $self->{checksums}{PAR::Repository::Client::DEPENDENCIES_DBM_FILE().".zip"};
+  }
+
+  return 1;
+}
+
+
+=head1 PRIVATE METHODS
+
+These private methods should not be relied upon from the outside of
+the module.
+
+=head2 _get_a_dbm
+
+This is a private method.
+
+Generic method returning a dbm.
+Requires two arguments. The type of the DBM (C<modules>,
+C<scripts>, C<dependencies>), and the name of the remote
+DBM file. The latter should be taken from one of the package
+constants.
+
+=cut
+
+sub _get_a_dbm {
+  my $self = shift;
+  $self->{error} = undef;
+
+  my $dbm_type       = shift;
+  my $dbm_remotefile = shift;
+
+  my $dbm_hashkey        = $dbm_type . "_dbm_hash";
+  my $tempfile_hashkey   = $dbm_type . "_dbm_temp_file";
+  my $dbm_remotefile_zip = $dbm_remotefile . ".zip";
+
+  my $checksums = $self->need_dbm_update($dbm_remotefile);
+
+  if ($self->{$dbm_hashkey}) {
+    # need new dbm file?
+    return($self->{$dbm_hashkey}, $self->{$tempfile_hashkey})
+      if not $checksums;
+
+    # does this particular dbm need to be updated?
+    if ($self->{checksums}) {
+      my $local_checksum = $self->{checksums}{$dbm_remotefile_zip};
+      my $remote_checksum = $checksums->{$dbm_remotefile_zip};
+      return($self->{$dbm_hashkey}, $self->{$tempfile_hashkey})
+        if defined $local_checksum and defined $remote_checksum
+           and $local_checksum eq $remote_checksum;
+    }
+
+    # just to make sure
+    my $method = 'close_' . $dbm_type . "_dbm";
+    $self->$method;
+  }
+
+  my $file;
+  if ($checksums) {
+    $file = $self->_fetch_dbm_file($dbm_remotefile_zip);
+    # (error set by _fetch_dbm_file)
+    return() if not defined $file; # or not -f $file; # <--- _fetch_dbm_file should do the stat!
+  }
+  else {
+    # cached!
+    $file = File::Spec->catfile($self->{cache_dir}, $dbm_remotefile_zip);
+    $self->{error} = "Cache miss error: Expected $file to exist, but it doesn't" if not -f $file;
+  }
+
+  my ($tempfh, $tempfile) = File::Temp::tempfile(
+    'temporary_dbm_XXXXX',
+    UNLINK => 0,
+    DIR => File::Spec->tmpdir(),
+    EXLOCK => 0, # FIXME no exclusive locking or else we block on BSD. What's the right solution?
+  );
+
+  if (not $self->_unzip_file($file, $tempfile, $dbm_remotefile)) {
+    $self->{error} = "Could not unzip dbm file '$file' to '$tempfile'";
+    unlink($tempfile);
+    return();
+  }
+
+  $self->{$tempfile_hashkey} = $tempfile;
+
+  my %hash;
+  my $obj = tie %hash, "DBM::Deep", {
+    file => $tempfile,
+    locking => 1,
+    autoflush => 0,
+  }; 
+
+  $self->{$dbm_hashkey} = \%hash;
+
+  # save this dbm file checksum
+  if (ref($checksums)) {
+    if (not $self->{checksums}) {
+      $self->{checksums} = {};
+    }
+    $self->{checksums}{$dbm_remotefile_zip} = $checksums->{$dbm_remotefile_zip};
+  }
+
+  return (\%hash, $tempfile);
+}
+
+
+=head2 _parse_dbm_checksums
+
+This is a private method.
+
+Given a reference to a file handle, a reference to a string
+or a file name, this method parses a checksum file
+and returns a hash reference associating file names
+with their base64 encoded MD5 hashes.
+
+If passed a ref to a string, the contents of the string will
+be assumed to contain the checksum data.
+
+=cut
+
+sub _parse_dbm_checksums {
+  my $self = shift;
+  $self->{error} = undef;
+
+  my $file_or_fh = shift;
+  my $is_string = 0;
+  my $fh;
+  if (ref($file_or_fh) eq 'GLOB') {
+    $fh = $file_or_fh;
+  }
+  elsif (ref($file_or_fh) eq 'SCALAR') {
+    $is_string = 1;
+  }
+  else {
+    open $fh, '<', $file_or_fh
+      or die "Could not open file '$file_or_fh' for reading: $!";
+  }
+
+  my $hashes = {};
+  my @lines;
+  @lines = split /\n/, $$file_or_fh if $is_string;
+
+  while (1) {
+    local $_ = $is_string ? shift @lines : <$fh>;
+    last if not defined $_;
+    next if /^\s*$/ or /^\s*#/;
+    my ($file, $hash) = split /\t/, $_;
+    if (not defined $file or not defined $hash) {
+      $self->{error} = "Error reading repository checksums.";
+      return();
+    }
+    $hash =~ s/\s+$//;
+    $hashes->{$file} = $hash;
+  }
+
+  return $hashes;
+}
+
+
+=head2 _calculate_cache_local_checksums
+
+This is a private method.
+
+Calculates the checksums of the DBMs in the local cache directory.
+If the repository client isn't using a private cache directory, this
+B<short circuits> and does not actually try to calculate
+any checksums of potentially modified files.
+
+Returns the checksums hash just like the checksum fetching
+routine.
+
+Maintainer note: Essentially the same code lives in
+PAR::Repository's DBM code for calculating the repository checksums
+in the first place.
+
+=cut
+
+sub _calculate_cache_local_checksums {
+  my $self = shift;
+
+  # only support inter-run cache summing if we're in a private cache dir!
+  if (!$self->{private_cache_dir}) {
+    return();
+  }
+
+  # 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 ($@) {
+    return();
+  }
+  
+  my $hashes = {};
+  # calculate local hashes
+  foreach my $dbmfile (
+      PAR::Repository::Client::MODULES_DBM_FILE(),
+      PAR::Repository::Client::SCRIPTS_DBM_FILE(),
+      PAR::Repository::Client::SYMLINKS_DBM_FILE(),
+      PAR::Repository::Client::DEPENDENCIES_DBM_FILE(),
+    ) {
+    my $filepath = File::Spec->catfile($self->{cache_dir}, $dbmfile.'.zip');
+    next unless -f $filepath;
+    open my $fh, '<', $filepath
+      or die "Could not open DBM file '$filepath' for reading: $!";
+    local $/ = undef;
+    my $hash = $md5_function->(<$fh>);
+    close $fh;
+    $hashes->{$dbmfile.'.zip'} = $hash;
+  } # end foreach dbm files
+
+  return $hashes; 
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+This module is directly related to the C<PAR> project. You need to have
+basic familiarity with it. Its homepage is at L<http://par.perl.org/>
+
+See L<PAR>, L<PAR::Dist>, L<PAR::Repository>, etc.
+
+L<PAR::Repository::Query> implements the querying interface. The methods
+described in that module's documentation can be called on
+C<PAR::Repository::Client> objects.
+
+L<PAR::Repository> implements the server side creation and manipulation
+of PAR repositories.
+
+L<PAR::WebStart> is doing something similar but is otherwise unrelated.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Steffen Mueller
+
+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

database/perl/vendor/lib/PAR/Repository/Client/HTTP.pm

@@ -0,0 +1,332 @@
+package PAR::Repository::Client::HTTP;
+
+use 5.006;
+use strict;
+use warnings;
+
+use vars qw/$ua/;
+require LWP::Simple;
+LWP::Simple->import('$ua');
+
+use base 'PAR::Repository::Client';
+
+use Carp qw/croak/;
+
+our $VERSION = '0.24';
+
+=head1 NAME
+
+PAR::Repository::Client::HTTP - PAR repository via HTTP
+
+=head1 SYNOPSIS
+
+  use PAR::Repository::Client;
+  
+  my $client = PAR::Repository::Client->new(
+    uri => 'http:///foo/repository',
+    http_timeout => 20, # but default is 180s
+  );
+
+=head1 DESCRIPTION
+
+This module implements repository accesses via HTTP.
+
+If you create a new L<PAR::Repository::Client> object and pass it
+an uri parameter which starts with C<http://> or C<https://>,
+it will create an object of this class. It inherits from
+C<PAR::Repository::Client>.
+
+The repository is accessed using L<LWP::Simple>.
+
+=head2 EXPORT
+
+None.
+
+=head1 METHODS
+
+Following is a list of class and instance methods.
+(Instance methods until otherwise mentioned.)
+
+=cut
+
+
+=head2 fetch_par
+
+Fetches a .par distribution from the repository and stores it
+locally. Returns the name of the local file or the empty list on
+failure.
+
+First argument must be the distribution name to fetch.
+
+=cut
+
+sub fetch_par {
+  my $self = shift;
+  $self->{error} = undef;
+  my $dist = shift;
+  return() if not defined $dist;
+
+  my $url = $self->{uri};
+  $url =~ s/\/$//;
+
+  my ($n, $v, $a, $p) = PAR::Dist::parse_dist_name($dist);
+  $url .= "/$a/$p/$n-$v-$a-$p.par";
+
+  my $file = $self->_fetch_file($url);
+
+  if (not defined $file) {
+    $self->{error} = "Could not fetch distribution from URI '$url'";
+    return();
+  }
+
+  return $file;
+}
+
+
+{
+  my %escapes;
+  sub _fetch_file {
+    my $self = shift;
+    $self->{error} = undef;
+    my $file = shift;
+    #warn "FETCHING FILE: $file";
+
+    my $cache_dir = $self->{cache_dir}; # used to be PAR_TEMP, but now configurable
+    %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255 unless %escapes;
+
+    $file =~ m!/([^/]+)$!;
+    my $local_file = (defined($1) ? $1 : $file);
+    $local_file =~ s/([^\w\._])/$escapes{$1}/g;
+    $local_file = File::Spec->catfile( $self->{cache_dir}, $local_file );
+
+    my $timeout = $self->{http_timeout};
+    my $old_timeout = $ua->timeout();
+    $ua->timeout($timeout) if defined $timeout;
+    my $rc = LWP::Simple::mirror( $file, $local_file );
+    $ua->timeout($old_timeout) if defined $timeout;
+    if (!LWP::Simple::is_success($rc) and not $rc == HTTP::Status::RC_NOT_MODIFIED()) {
+      $self->{error} = "Error $rc: " . LWP::Simple::status_message($rc) . " ($file)\n";
+      return();
+    }
+
+    return $local_file if -f $local_file;
+    return();
+  }
+}
+
+
+sub _fetch_as_data {
+  my $self = shift;
+  $self->{error} = undef;
+  my $file = shift;
+  #warn "FETCHING DATA: $file";
+
+  my $timeout = $self->{http_timeout};
+  my $old_timeout = $ua->timeout();
+  $ua->timeout($timeout) if defined $timeout;
+  my $data = LWP::Simple::get( $file );
+  $ua->timeout($old_timeout) if defined $timeout;
+
+  return $data if defined $data;
+
+  $self->{error} = "Could not get '$file' from repository";
+  return();
+}
+
+
+=head2 validate_repository
+
+Makes sure the repository is valid. Returns the empty list
+if that is not so and a true value if the repository is valid.
+
+Checks that the repository version is compatible.
+
+The error message is available as C<$client->error()> on
+failure.
+
+=cut
+
+sub validate_repository {
+  my $self = shift;
+  $self->{error} = undef;
+
+  my $mod_db = $self->modules_dbm;
+  return() if not defined $mod_db;
+
+  return() if not $self->validate_repository_version;
+
+  return 1;
+}
+
+
+=head2 _repository_info
+
+Returns a YAML::Tiny object representing the repository meta
+information.
+
+This is a private method.
+
+=cut
+
+sub _repository_info {
+  my $self = shift;
+  $self->{error} = undef;
+  return $self->{info} if defined $self->{info};
+
+  my $url = $self->{uri};
+  $url =~ s/\/$//;
+
+  my $file = $self->_fetch_file(
+    $url.'/'.PAR::Repository::Client::REPOSITORY_INFO_FILE()
+  );
+
+  return() if not defined $file;
+
+  my $yaml = YAML::Tiny->new->read($file);
+  if (not defined $yaml) {
+    $self->{error} = "Error reading repository info from YAML file.";
+    return();
+  }
+
+  # workaround for possible YAML::Syck/YAML::Tiny bug
+  # This is not the right way to do it!
+  @$yaml = ($yaml->[1]) if @$yaml > 1;
+
+  $self->{info} = $yaml;
+  return $yaml;
+}
+
+
+=head2 _fetch_dbm_file
+
+This is a private method.
+
+Fetches a dbm (index) file from the repository and
+returns the name of the temporary local file or the
+empty list on failure.
+
+An error message is available via the C<error()>
+method in case of failure.
+
+=cut
+
+sub _fetch_dbm_file {
+  my $self = shift;
+  $self->{error} = undef;
+  my $file = shift;
+  return if not defined $file;
+
+  my $url = $self->{uri};
+  $url =~ s/\/$//;
+
+  my $local = $self->_fetch_file("$url/$file");
+  return() if not defined $local or not -f $local;
+
+  return $local;
+}
+
+
+=head2 _dbm_checksums
+
+This is a private method.
+
+If the repository has a checksums file (new feature of
+C<PAR::Repository> 0.15), this method returns a hash  
+associating the DBM file names (e.g. C<foo_bar.dbm.zip>)
+with their MD5 hashes (base 64).
+
+This method B<always> queries the repository and never caches
+the information locally. That's the whole point of having the
+checksums.
+
+In case the repository does not have checksums, this method
+returns the empty list, so check the return value!
+The error message (see the C<error()> method) will be
+I<"Repository does not support checksums"> in that case.
+
+=cut
+
+sub _dbm_checksums {
+  my $self = shift;
+  $self->{error} = undef;
+
+  my $url = $self->{uri};
+  $url =~ s/\/$//;
+
+  # if we're running on a "trust-the-checksums-for-this-long" basis...
+  # ... return if the timeout hasn't elapsed
+  if ($self->{checksums} and $self->{checksums_timeout}) {
+    my $time = time();
+    if ($time - $self->{last_checksums_refresh} < $self->{checksums_timeout}) {
+      return($self->{checksums});
+    }
+  }
+
+  my $data = $self->_fetch_as_data(
+    $url.'/'.PAR::Repository::Client::DBM_CHECKSUMS_FILE()
+  );
+
+  if (not defined $data) {
+    $self->{error} = "Repository does not support checksums";
+    return();
+  }
+
+  return $self->_parse_dbm_checksums(\$data);
+}
+
+
+=head2 _init
+
+This private method is called by the C<new()> method of
+L<PAR::Repository::Client>. It is used to initialize
+the client object and C<new()> passes it a hash ref to
+its arguments.
+
+Should return a true value on success.
+
+=cut
+
+sub _init {
+  my $self = shift;
+  my $args = shift || {};
+  # We implement additional object attributes here
+  $self->{http_timeout} = $args->{http_timeout};
+  $self->{http_timeout} = 180 if not defined $self->{http_timeout};
+
+  return 1;
+}
+
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+This module is part of the L<PAR::Repository::Client> distribution.
+
+This module is directly related to the C<PAR> project. You need to have
+basic familiarity with it. The PAR homepage is at L<http://par.perl.org>.
+
+See L<PAR>, L<PAR::Dist>, L<PAR::Repository>, etc.
+
+L<PAR::Repository> implements the server side creation and manipulation
+of PAR repositories.
+
+L<PAR::WebStart> is doing something similar but is otherwise unrelated.
+
+The repository access is done via L<LWP::Simple>.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006-2009 by Steffen Mueller
+
+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

database/perl/vendor/lib/PAR/Repository/Client/Local.pm

@@ -0,0 +1,285 @@
+package PAR::Repository::Client::Local;
+
+use 5.006;
+use strict;
+use warnings;
+
+use base 'PAR::Repository::Client';
+
+use Carp qw/croak/;
+require File::Copy;
+
+our $VERSION = '0.24';
+
+=head1 NAME
+
+PAR::Repository::Client::Local - PAR repo. on the local file system
+
+=head1 SYNOPSIS
+
+  use PAR::Repository::Client;
+  
+  my $client = PAR::Repository::Client->new(
+    uri => 'file:///foo/repository',
+  );
+
+=head1 DESCRIPTION
+
+This module implements repository accesses on the local filesystem.
+
+If you create a new L<PAR::Repository::Client> object and pass it
+an uri parameter which starts with C<file://> or just a path,
+it will create an object of this class. It inherits from
+C<PAR::Repository::Client>.
+
+=head2 EXPORT
+
+None.
+
+=head1 METHODS
+
+Following is a list of class and instance methods.
+(Instance methods until otherwise mentioned.)
+
+=cut
+
+=head2 fetch_par
+
+Fetches a .par distribution from the repository and stores it
+locally. Returns the name of the local file or the empty list on
+failure.
+
+First argument must be the distribution name to fetch.
+
+=cut
+
+sub fetch_par {
+  my $self = shift;
+  $self->{error} = undef;
+  my $dist = shift;
+  if (not defined $dist) {
+    $self->{error} = "undef passed as argument to fetch_par()";
+    return();
+  }
+
+  my $path = $self->{uri};
+  $path =~ s/(?:\/|\\)$//;
+  $path =~ s!^file://!!i;
+
+  my ($dname, $vers, $arch, $perl) = PAR::Dist::parse_dist_name($dist);
+  my $file = File::Spec->catfile(
+    File::Spec->catdir($path, $arch, $perl),
+    "$dname-$vers-$arch-$perl.par"
+  );
+
+  if (not -f $file) {
+    $self->{error} = "Could not find distribution in local repository at '$file'";
+    return();
+  }
+
+  return $file;
+}
+
+=head2 validate_repository
+
+Makes sure the repository is valid. Returns the empty list
+if that is not so and a true value if the repository is valid.
+
+Checks that the repository version is compatible.
+
+The error message is available as C<$client->error()> on
+failure.
+
+=cut
+
+sub validate_repository {
+  my $self = shift;
+  $self->{error} = undef;
+
+  my $mod_db = $self->modules_dbm;
+
+  return() unless defined $mod_db;
+
+  return() unless $self->validate_repository_version;
+
+  return 1;
+}
+
+=head2 _repository_info
+
+Returns a YAML::Tiny object representing the repository meta
+information.
+
+This is a private method.
+
+=cut
+
+sub _repository_info {
+  my $self = shift;
+  $self->{error} = undef;
+  return $self->{info} if defined $self->{info};
+
+  my $path = $self->{uri};
+  $path =~ s/(?:\/|\\)$//;
+  $path =~ s!^file://!!i;
+
+  my $file = File::Spec->catfile($path, PAR::Repository::Client::REPOSITORY_INFO_FILE());
+
+  if (not defined $file or not -f $file) {
+    $self->{error} = "File '$file' does not exist in repository.";
+    return();
+  }
+
+  my $yaml = YAML::Tiny->new->read($file);
+  if (not defined $yaml) {
+    $self->{error} = "Error reading repository info from YAML file.";
+    return();
+  }
+
+  # workaround for possible YAML::Syck/YAML::Tiny bug
+  # This is not the right way to do it!
+  @$yaml = ($yaml->[1]) if @$yaml > 1;
+  $self->{info} = $yaml;
+  return $yaml;
+}
+
+=head2 _fetch_dbm_file
+
+This is a private method.
+
+Fetches a dbm (index) file from the repository and
+returns the name of the local file or the
+empty list on failure.
+
+An error message is available via the C<error()>
+method in case of failure.
+
+=cut
+
+sub _fetch_dbm_file {
+  my $self = shift;
+  $self->{error} = undef;
+  my $file = shift;
+  return if not defined $file;
+
+  my $path = $self->{uri};
+  $path =~ s/(?:\/|\\)$//;
+  $path =~ s!^file://!!i;
+
+  my $url = File::Spec->catfile( $path, $file );
+
+  if (not -f $url) {
+    $self->{error} = "Could not find dbm file in local repository at '$url'";
+    return();
+  }
+
+  my ($tempfh, $tempfile) = File::Temp::tempfile(
+    'temp_zip_dbm_XXXXX',
+    UNLINK => 1, # because we cache the suckers by default
+    DIR => $self->{cache_dir},
+    EXLOCK => 0, # FIXME no exclusive locking or else we block on BSD. What's the right solution?
+  );
+
+  File::Copy::copy($url, $tempfile);
+
+  return $tempfile;
+}
+
+
+
+=head2 _dbm_checksums
+
+This is a private method.
+
+If the repository has a checksums file (new feature of
+C<PAR::Repository> 0.15), this method returns a hash  
+associating the DBM file names (e.g. C<foo_bar.dbm.zip>)
+with their MD5 hashes (base 64).
+
+This method B<always> queries the repository and never caches
+the information locally. That's the whole point of having the
+checksums.
+
+In case the repository does not have checksums, this method
+returns the empty list, so check the return value!
+The error message (see the C<error()> method) will be
+I<"Repository does not support checksums"> in that case.
+
+=cut
+
+sub _dbm_checksums {
+  my $self = shift;
+  $self->{error} = undef;
+
+  my $path = $self->{uri};
+  $path =~ s/(?:\/|\\)$//;
+  $path =~ s!^file://!!i;
+
+  # if we're running on a "trust-the-checksums-for-this-long" basis...
+  # ... return if the timeout hasn't elapsed
+  if ($self->{checksums} and $self->{checksums_timeout}) {
+    my $time = time();
+    if ($time - $self->{last_checksums_refresh} < $self->{checksums_timeout}) {
+      return($self->{checksums});
+    }
+  }
+
+  my $file = File::Spec->catfile($path, PAR::Repository::Client::DBM_CHECKSUMS_FILE());
+
+  if (not defined $file or not -f $file) {
+    $self->{error} = "Repository does not support checksums";
+    return();
+  }
+
+  return $self->_parse_dbm_checksums($file);
+}
+
+
+=head2 _init
+
+This private method is called by the C<new()> method of
+L<PAR::Repository::Client>. It is used to initialize
+the client object and C<new()> passes it a hash ref to
+its arguments.
+
+Should return a true value on success.
+
+=cut
+
+sub _init {
+  # We implement additional object attributes here
+  # Currently no extra attributes...
+  return 1;
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+This module is part of the L<PAR::Repository::Client> distribution.
+
+This module is directly related to the C<PAR> project. You need to have
+basic familiarity with it. The PAR homepage is at L<http://par.perl.org/>.
+
+See L<PAR>, L<PAR::Dist>, L<PAR::Repository>, etc.
+
+L<PAR::Repository> implements the server side creation and manipulation
+of PAR repositories.
+
+L<PAR::WebStart> is doing something similar but is otherwise unrelated.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Steffen Mueller
+
+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

database/perl/vendor/lib/PAR/Repository/Client/Util.pm

@@ -0,0 +1,136 @@
+package PAR::Repository::Client::Util;
+
+use 5.006;
+use strict;
+use warnings;
+
+our $VERSION = '0.24';
+
+use Carp qw/croak/;
+
+=head1 NAME
+
+PAR::Repository::Client::Util - Small helper methods common to all implementations
+
+=head1 SYNOPSIS
+
+  use PAR::Repository::Client;
+
+=head1 DESCRIPTION
+
+This module implements small helper methods which are common to all
+L<PAR::Repository::Client> implementations.
+
+=head1 PRIVATE METHODS
+
+These private methods should not be relied upon from the outside of
+the module.
+
+=head2 _unzip_file
+
+This is a private method. Callable as class or instance method.
+
+Unzips the file given as first argument to the file
+given as second argument.
+If a third argument is used, the zip member of that name
+is extracted. If the zip member name is omitted, it is
+set to the target file name.
+
+Returns the name of the unzipped file.
+
+=cut
+
+sub _unzip_file {
+  my $class = shift;
+  my $file = shift;
+  my $target = shift;
+  my $member = shift;
+  $member = $target if not defined $member;
+  return unless -f $file;
+
+  my $zip = Archive::Zip->new;
+  local %SIG;
+  $SIG{__WARN__} = sub { print STDERR $_[0] unless $_[0] =~ /\bstat\b/ };
+
+  return unless $zip->read($file) == Archive::Zip::AZ_OK()
+    and $zip->extractMember($member, $target) == Archive::Zip::AZ_OK();
+
+  return $target;
+}
+
+
+# given a distribution name, recursively determines all distributions
+# it depends on
+sub _resolve_static_dependencies {
+  my $self = shift;
+  my $distribution = shift;
+
+  my ($deph) = $self->dependencies_dbm();
+  return([]) if not exists $deph->{$distribution};
+  
+  my ($modh) = $self->modules_dbm();
+
+  my @module_queue = (keys %{$deph->{$distribution}});
+  my @dep_dists;
+  my %module_seen;
+  my %dist_seen;
+
+  while (@module_queue) {
+    #use Data::Dumper; warn Dumper \@module_queue;
+    my $module = shift @module_queue;
+    next if $module_seen{$module}++;
+    next if not exists $modh->{$module}; # FIXME should this be somehow reported?
+    my $dist = $self->prefered_distribution($module, $modh->{$module});
+    next if not defined $dist;
+    next if $dist_seen{$dist}++;
+    push @dep_dists, $dist;
+    push @module_queue, keys %{$deph->{$dist}} if exists $deph->{$dist};
+  }
+
+  return \@dep_dists;
+}
+
+sub generate_private_cache_dir {
+  my $self = shift;
+  my $uri = $self->{uri};
+  my $digester = PAR::SetupTemp::_get_digester(); # requires PAR 0.987!
+  $digester->add($uri);
+  my $digest = $digester->b64digest();
+  $digest =~ s/\W/_/g;
+  my $user_temp_dir = PAR::SetupTemp::_get_par_user_tempdir();
+  my $priv_cache_dir = File::Spec->catdir($user_temp_dir, "par-repo-$digest");
+  return $priv_cache_dir;
+}
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+This module is directly related to the C<PAR> project. You need to have
+basic familiarity with it. Its homepage is at L<http://par.perl.org/>
+
+See L<PAR>, L<PAR::Dist>, L<PAR::Repository>, etc.
+
+L<PAR::Repository::Query> implements the querying interface. The methods
+described in that module's documentation can be called on
+C<PAR::Repository::Client> objects.
+
+L<PAR::Repository> implements the server side creation and manipulation
+of PAR repositories.
+
+L<PAR::WebStart> is doing something similar but is otherwise unrelated.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Steffen Mueller
+
+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

database/perl/vendor/lib/PAR/Repository/Query.pm

@@ -0,0 +1,410 @@
+package PAR::Repository::Query;
+
+use 5.006;
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+
+our $VERSION = '0.14';
+
+=head1 NAME
+
+PAR::Repository::Query - Implements repository queries
+
+=head1 SYNOPSIS
+
+  use PAR::Repository;
+  # or:
+  use PAR::Repository::Client;
+
+=head1 DESCRIPTION
+
+This module is for internal use by L<PAR::Repository> or
+L<PAR::Repository::Client> only. Both modules inherit from this.
+C<PAR::Repository::Query> implements a unified query interface for
+both the server- and client-side components of PAR repositories.
+
+If you decide to inherit from this class (for whatever reason),
+you should provide at least two methods: C<modules_dbm> which returns
+a L<DBM::Deep> object representing the modules DBM file.
+(See L<PAR::Repository::DBM> for details.) And C<scripts_dbm> which is
+the equivalent for the scripts DBM file.
+
+=head2 EXPORT
+
+None. But the methods are callable on C<PAR::Repository> and 
+C<PAR::Repository::Client> objects.
+
+=head1 METHODS
+
+Following is a list of class and instance methods.
+(Instance methods until otherwise mentioned.)
+
+There is no C<PAR::Repository::Query> object.
+
+=cut
+
+=head2 query_module
+
+Polls the repository for modules matching certain criteria.
+Takes named arguments. Either a C<regex> or a C<name> parameter
+must be present but not both.
+
+Returns a reference to an array containing alternating distribution
+file names and module versions. This method returns the following
+structure
+
+  [ 'Foo-Bar-0.01-any_arch-5.8.7.par', '0.01', ... ]
+
+that means the module was found in the distribution
+F<Foo-Bar-0.01-any_arch-5.8.7.par> and the copy in that file has version
+0.01.
+
+Parameters:
+
+=over 2
+
+=item B<name>
+
+The name of the module to look for. This is used for an exact match.
+If you want to find C<Foo> in C<Foo::Bar>, use the C<regex> parameter.
+Only one of C<name> and C<regex> may be specified.
+
+=item B<regex>
+
+Same as C<name>, but interpreted as a regular expression.
+Only one of C<name> and C<regex> may be specified.
+
+=item B<arch>
+
+Can be used to reduce the number of matches to a specific architecture.
+Always interpreted as a regular expression.
+
+=back
+
+=cut
+
+sub query_module {
+    my $self = shift;
+#    $self->verbose(2, "Entering query_module()");
+    croak("query_module() called with uneven number of arguments.")
+      if @_ % 2;
+    my %args = @_;
+    
+    my $name = $args{name};
+    my $regex = $args{regex};
+
+    if (defined $name and defined $regex) {
+        croak("query_module() accepts only one of 'name' and 'regex' parameters.");
+    }
+    elsif (not defined $name and not defined $regex) {
+        croak("query_module() needs one of 'name' and 'regex' parameters.");
+    }
+    elsif (defined $name) {
+        $regex = qr/^\Q$name\E$/;
+    }
+    else { # regex defined
+        $regex = qr/$regex/ if not ref($regex) eq 'Regexp';
+    }
+
+    my ($modh, $modfile) = $self->modules_dbm
+      or die("Could not get modules DBM.");
+
+    my @modules;
+    
+    my $arch_regex = $args{arch};
+    $arch_regex = qr/$arch_regex/
+      if defined $arch_regex and not ref($arch_regex) eq 'Regexp';
+    
+    # iterate over all modules in the mod_dbm hash
+    while (my ($mod_name, $dists) = each(%$modh)) {
+        # skip non-matching
+        next if $mod_name !~ $regex;
+        
+        if (defined $arch_regex) {
+            while (my ($distname, $version) = each(%$dists)) {
+                (undef, undef, my $arch, undef)
+                  = PAR::Dist::parse_dist_name($distname);
+                next if $arch !~ $arch_regex;
+                push @modules, [$distname, $version];
+            }
+        }
+        else {
+            while (my ($distname, $version) = each(%$dists)) {
+                push @modules, [$distname, $version];
+            }
+        }
+    }
+    
+    my %seen;
+    # sort return list alphabetically
+    return [
+        map  { @$_ }
+        sort { $a->[0] cmp $b->[0] }
+        grep { not $seen{$_->[0] . '|' . $_->[1]}++ }
+        @modules
+    ];
+}
+
+=head2 query_script
+
+Note: Usually, you probably want to use C<query_script_hash()>
+instead. The usage of both methods is very similar (and described
+right below), but the data structure returned differes somewhat.
+
+Polls the repository for scripts matching certain criteria.
+Takes named arguments. Either a C<regex> or a C<name> parameter
+must be present but not both.
+
+Returns a reference to an array containing alternating distribution
+file names and script versions. This method returns the following
+structure
+
+  [ 'Foo-Bar-0.01-any_arch-5.8.7.par', '0.01', ... ]
+
+that means the script was found in the distribution
+F<Foo-Bar-0.01-any_arch-5.8.7.par> and the copy in that file has version
+0.01.
+
+Parameters:
+
+=over 2
+
+=item B<name>
+
+The name of the script to look for. This is used for an exact match.
+If you want to find C<foo> in C<foobar>, use the C<regex> parameter.
+Only one of C<name> and C<regex> may be specified.
+
+=item B<regex>
+
+Same as C<name>, but interpreted as a regular expression.
+Only one of C<name> and C<regex> may be specified.
+
+=item B<arch>
+
+Can be used to reduce the number of matches to a specific architecture.
+Always interpreted as a regular expression.
+
+=back
+
+=cut
+
+# FIXME: factor out common code from query_script and query_module!
+sub query_script {
+    my $self = shift;
+#    $self->verbose(2, "Entering query_script()");
+
+    my $scripts = $self->query_script_hash(@_);
+
+    my %seen;
+    # sort return list alphabetically
+    return [
+        map  { @$_ }
+        sort { $a->[0] cmp $b->[0] }
+        grep { not $seen{$_->[0] . '|' . $_->[1]}++ }
+        map  {
+          my $scripthash = $scripts->{$_};
+          map { [$_, $scripthash->{$_}] } keys %$scripthash;
+        }
+        keys %$scripts
+    ];
+}
+
+
+=head2 query_script_hash
+
+Works exactly the same as C<query_script> except it returns
+a different resulting structure which includes the matching
+script's name:
+
+  { 'fooscript' => { 'Foo-Bar-0.01-any_arch-5.8.7.par' => '0.01', ... }, ... }
+
+that means the script C<fooscript> was found in the distribution
+F<Foo-Bar-0.01-any_arch-5.8.7.par> and the copy in that file has version
+0.01.
+
+Parameters are the same as for C<query_script>
+
+=cut
+
+# FIXME: factor out common code from query_script_hash and query_module!
+sub query_script_hash {
+    my $self = shift;
+#    $self->verbose(2, "Entering query_script_hash()");
+    croak("query_script() or query_script_hash() called with uneven number of arguments.")
+      if @_ % 2;
+    my %args = @_;
+    
+    my $name = $args{name};
+    my $regex = $args{regex};
+
+    if (defined $name and defined $regex) {
+        croak("query_script() or query_script_hash() accepts only one of 'name' and 'regex' parameters.");
+    }
+    elsif (not defined $name and not defined $regex) {
+        croak("query_script() or query_script_hash() needs one of 'name' and 'regex' parameters.");
+    }
+    elsif (defined $name) {
+        $regex = qr/^\Q$name\E$/;
+    }
+    else { # regex defined
+        $regex = qr/$regex/ if not ref($regex) eq 'Regexp';
+    }
+
+    my ($scrh, $scrfile) = $self->scripts_dbm
+      or die("Could not get scripts DBM.");
+
+    my %scripts;
+    
+    my $arch_regex = $args{arch};
+    $arch_regex = qr/$arch_regex/
+      if defined $arch_regex and not ref($arch_regex) eq 'Regexp';
+    
+    # iterate over all scripts in the scripts hash
+    while (my ($scr_name, $dists) = each(%$scrh)) {
+        # skip non-matching
+        next if $scr_name !~ $regex;
+        
+        while (my ($distname, $version) = each(%$dists)) {
+            if (defined $arch_regex) {
+                (undef, undef, my $arch, undef)
+                  = PAR::Dist::parse_dist_name($distname);
+                next if $arch !~ $arch_regex;
+            }
+            $scripts{$scr_name} = {} if not exists $scripts{$scr_name};
+            $scripts{$scr_name}{$distname} = $version; # distname => version
+        }
+    }
+
+    return \%scripts;    
+}
+
+
+
+=head2 query_dist
+
+Polls the repository for distributions matching certain criteria.
+Takes named arguments. Either a C<regex> or a C<name> parameter
+must be present but not both.
+
+Returns a reference to an array containing alternating distribution
+file names and hash references. The hashes contain module names
+and associated versions in the distribution.
+This method returns the following structure
+
+  [
+    'Foo-Bar-0.01-any_arch-5.8.7.par',
+    {Foo::Bar => '0.01', Foo::Bar::Baz => '0.02'},
+    ...
+  ]
+
+that means the distribution F<Foo-Bar-0.01-any_arch-5.8.7.par> matched and
+that distribution contains the modules C<Foo::Bar> and C<Foo::Bar::Baz>
+with versions 0.01 and 0.02 respectively.
+
+Parameters:
+
+=over 2
+
+=item B<name>
+
+The name of the distribution to look for. This is used for an exact match.
+If you want to find C<Foo> in C<Foo-Bar-0.01-any_arch-5.8.8.par>,
+use the C<regex> parameter.
+Only one of C<name> and C<regex> may be specified.
+
+=item B<regex>
+
+Same as C<name>, but interpreted as a regular expression.
+Only one of C<name> and C<regex> may be specified.
+
+=item B<arch>
+
+Can be used to reduce the number of matches to a specific architecture.
+Always interpreted as a regular expression.
+
+=back
+
+=cut
+
+sub query_dist {
+    my $self = shift;
+#    $self->verbose(2, "Entering query_dist()");
+    croak("query_dist() called with uneven number of arguments.")
+      if @_ % 2;
+    my %args = @_;
+    
+    my $name = $args{name};
+    my $regex = $args{regex};
+
+    if (defined $name and defined $regex) {
+        croak("query_dist() accepts only one of 'name' and 'regex' parameters.");
+    }
+    elsif (not defined $name and not defined $regex) {
+        croak("query_dist() needs one of 'name' and 'regex' parameters.");
+    }
+    elsif (defined $name) {
+        $regex = qr/^\Q$name\E$/;
+    }
+    else { # regex defined
+        $regex = qr/$regex/ if not ref($regex) eq 'Regexp';
+    }
+
+    my ($modh, $modfile) = $self->modules_dbm
+      or die("Could not get modules DBM.");
+
+    my %dists;
+    
+    my $arch_regex = $args{arch};
+    $arch_regex = qr/$arch_regex/
+      if defined $arch_regex and not ref($arch_regex) eq 'Regexp';
+    
+    # iterate over all modules in the mod_dbm hash
+    while (my ($mod_name, $this_dists) = each(%$modh)) {
+        # get the distributions for the module
+        my $this_dists = $modh->{$mod_name};
+        
+        while (my ($dist_name, $dist) = each(%$this_dists)) {
+            # skip non-matching
+            next if $dist_name !~ $regex;
+            
+            # skip non-matching archs
+            if (defined $arch_regex) {
+                (undef, undef, my $arch, undef)
+                  = PAR::Dist::parse_dist_name($dist_name);
+                next if $arch !~ $arch_regex;
+            }
+            
+            $dists{$dist_name}{$mod_name} = $dist;
+        }
+    }
+    
+    # sort return list alphabetically
+    return [
+        map  { @$_ }
+        sort { $a->[0] cmp $b->[0] }
+        map  { [$_, $dists{$_}] }
+        keys %dists
+    ];
+}
+
+
+
+1;
+__END__
+
+=head1 AUTHOR
+
+Steffen Müller, E<lt>smueller@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006-2009 by Steffen Mü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