KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

501
database/perl/vendor/lib/PAR/Repository/Client/DBM.pm vendored Normal file
View File

@@ -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

332
database/perl/vendor/lib/PAR/Repository/Client/HTTP.pm vendored Normal file
View File

@@ -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

285
database/perl/vendor/lib/PAR/Repository/Client/Local.pm vendored Normal file
View File

@@ -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

136
database/perl/vendor/lib/PAR/Repository/Client/Util.pm vendored Normal file
View File

@@ -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