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

1426
database/perl/vendor/lib/PAR/Dist.pm vendored Normal file
View File

File diff suppressed because it is too large Load Diff

555
database/perl/vendor/lib/PAR/Dist/FromPPD.pm vendored Normal file
View File

@@ -0,0 +1,555 @@
package PAR::Dist::FromPPD;
use 5.006;
use strict;
use warnings;
our $VERSION = '0.03';
use PAR::Dist;
use LWP::Simple ();
use XML::Parser;
use Cwd qw/cwd abs_path/;
use File::Copy;
use File::Spec;
use File::Path;
use File::Temp ();
use Archive::Tar ();
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(
ppd_to_par get_ppd_content
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
ppd_to_par
);
our $VERBOSE = 0;
sub _verbose {
$VERBOSE = shift if (@_);
return $VERBOSE
}
sub _diag {
my $msg = shift;
return unless _verbose();
print $msg ."\n";
}
sub ppd_to_par {
die "Uneven number of arguments to 'ppd_to_par'." if @_ % 2;
my %args = @_;
my @par_files;
_verbose($args{'verbose'});
if (not defined $args{uri}) {
die "You need to specify an URI for the PPD file";
}
my $ppd_uri = $args{uri};
my $outdir = abs_path(defined($args{out}) ? $args{out} : '.');
die "Output path not a directory." if not -d $outdir;
_diag "Looking for PPD.";
my $ppd_text = get_ppd_content($ppd_uri);
_diag "Parsing PPD XML.";
my $parser = XML::Parser->new(Style => 'Tree');
my $ppd_tree = $parser->parse($ppd_text);
die "Parsing PPD XML failed" if not defined $ppd_tree;
my $ppd_info = _ppd_to_info($ppd_tree);
die "Malformed PPD" if not defined $ppd_info;
_diag "Applying user overrides.";
# override parsed data with user specified data
my %arg_map = (
distname => 'name',
distversion => 'version',
);
_override_info($ppd_info, \%arg_map, \%args);
if (not defined $ppd_info->{name}) {
die "Missing distribution name";
}
if (not defined $ppd_info->{version}) {
die "Missing distribution version";
}
if (not @{$ppd_info->{implementations}}) {
die "No IMPLEMENTATION sections in the distribution";
}
# Select implementation
_diag "Selecting implementation.";
my $implem = [@{$ppd_info->{implementations}}];
my $chosen;
my $sperl = $args{selectperl};
$sperl = qr/$sperl/ if defined $sperl;
my $sarch = $args{selectarch};
$sarch = qr/$sarch/ if defined $sarch;
if (not $sarch) {
if (not $sperl) {
$chosen = $implem->[0];
}
else {
# have $sperl not $sarch
foreach my $impl (@$implem) {
if ($impl->{perl} and $impl->{perl} =~ $sperl) {
$chosen = $impl;
last;
}
}
$chosen = $implem->[0] if not $chosen;
}
}
else {
# have $sarch
if (not $sperl) {
foreach my $impl (@$implem) {
if ($impl->{arch} and $impl->{arch} =~ $sarch) {
$chosen = $impl;
last;
}
}
$chosen = $implem->[0] if not $chosen;
}
else {
# both
my @pre;
foreach my $impl (@$implem) {
if ($impl->{arch} and $impl->{arch} =~ $sarch) {
push @pre, $impl;
}
}
if (not @pre) {
$chosen = $implem->[0];
}
else {
foreach my $impl (@pre) {
if ($impl->{perl} and $impl->{perl} =~ $sperl) {
$chosen = $impl;
last;
}
}
$chosen = $pre[0] if not $chosen;
}
}
}
# apply the rest of the overrides
%arg_map = (
arch => [qw(implementations arch)],
perlversion => [qw(implementations perl)],
);
_override_info($ppd_info, \%arg_map, \%args);
if (not defined $chosen->{arch}) {
die "Architecture name of chosen implementation is undefined"
}
if (not defined $chosen->{perl}) {
die "Minimum perl version of chosen implementation is undefined"
}
_diag "Creating temporary directory";
my $tdir = File::Temp::tempdir( CLEANUP => 1 );
_diag "Fetching (or finding) implementation file";
my $impl_file;
foreach my $uri (@{$chosen->{uri}}) {
my $filename = $uri;
$filename =~ s/^.*(?:\/|\\|:)([^\\\/:]+)$/$1/;
my $localfile = File::Spec->catfile($tdir, $filename);
if ($uri =~ /^(?:ftp|https?):\/\//) {
my $code = LWP::Simple::getstore(
$uri, $localfile
);
_diag("URI '$uri' via LWP '$localfile' failed. (LWP, code $code)"), next
if not LWP::Simple::is_success($code);
$impl_file = $localfile;
}
elsif ($uri =~ /^file:\/\// or $uri !~ /^\w+:\/\//) {
# local file
unless(-f $uri and File::Copy::copy($uri, $localfile)) {
_diag "URI '$uri' failed. (local)";
# try as relative URI
my $base = $args{uri};
if ($base =~ /^(?:https?|ftp):\/\//) {
$base =~ s!/[^/]+$!/$uri!;
my $code = LWP::Simple::getstore(
$base, $localfile
);
_diag("URI '$base' via LWP '$localfile' failed. (LWP, code $code)"), next
if not LWP::Simple::is_success($code);
$impl_file = $localfile;
}
else {
next;
}
}
$impl_file = $localfile;
}
else {
_diag "Invalid URI '$uri'.";
next;
}
}
if (not defined $impl_file) {
_diag "All CODEBASEs failed.";
File::Path::rmtree([$tdir]);
return();
}
_diag "Local file: '$impl_file'";
_diag "chdir() to '$tdir'";
my $cwd = Cwd::cwd();
chdir($tdir);
_diag "Generating 'blib' stub'";
PAR::Dist::generate_blib_stub(
name => $ppd_info->{name},
version => $ppd_info->{version},
suffix => join('-', $chosen->{arch}, $chosen->{perl}),
);
_diag "Extracting local file.";
my ($vol, $path, $file) = File::Spec->splitpath($impl_file);
my $tar = Archive::Tar->new($file, 1)
or chdir($cwd), die "Could not open .tar(.gz) file";
$tar->extract();
_diag "Building PAR ".$ppd_info->{name};
my $par_file;
eval {
$par_file = PAR::Dist::blib_to_par(
name => $ppd_info->{name},
version => $ppd_info->{version},
suffix => join('-', $chosen->{arch}, $chosen->{perl}).'.par',
)
} or chdir($cwd), die "Failed to build .par: $@";
chdir($cwd), die "Could not find PAR distribution file '$par_file'."
if not -f $par_file;
_diag "Built PAR file '$par_file'.";
_diag "Moving distribution file to output directory '$outdir'.";
unless (File::Copy::move($par_file, $outdir)) {
chdir($cwd);
die "Could not move file '$par_file' to directory "
. "'$outdir'. Reason: $!";
}
$par_file = File::Spec->catfile($outdir, $par_file);
if (-f $par_file) {
push @par_files, $par_file;
}
else {
chdir($cwd);
die "Lost PAR file along the way. (Ouch!) Expected it at '$par_file'";
}
# strip docs
if ($args{strip_docs}) {
_diag "Removing documentation from the PAR distribution(s).";
PAR::Dist::remove_man($_) for @par_files;
}
chdir($cwd);
File::Path::rmtree([$tdir]);
return(1);
}
sub get_ppd_content {
my $ppd_uri = shift;
my $ppd_text;
if ($ppd_uri =~ /^(?:https?|ftp):\/\//) {
# fetch with LWP::Simple
_diag "Fetching with LWP::Simple.";
$ppd_text = LWP::Simple::get($ppd_uri);
die "Could not fetch PPD content from '$ppd_uri' using LWP"
if not defined $ppd_text;
}
elsif ($ppd_uri =~ /^file:\/\// or $ppd_uri !~ /^\w*:\/\//) {
# It's a local file
_diag "Reading PPD info from file.";
$ppd_uri =~ s/^file:\/\///;
open my $fh, '<', $ppd_uri
or die "Could not read PPD content from file '$ppd_uri' ($!)";
local $/ = undef;
$ppd_text = <$fh>;
close $fh;
die "Could not read PPD content from file '$ppd_uri' ($!)"
if not defined $ppd_text;
}
else {
# Invalid URI (in our context)
die "The PPD URI is invalid: '$ppd_uri'";
}
return $ppd_text;
}
sub _ppd_to_info {
my $tree = shift;
my $info = {
name => undef,
version => undef,
title => undef,
abstract => undef,
author => undef,
license => undef,
deps => [],
implementations => [],
};
return() if not defined $tree or not ref($tree) eq 'ARRAY';
return() if not $tree->[0] =~ /^softpkg$/i;
my $children = $tree->[1];
my $dist_attr = shift @$children;
$info->{name} = $dist_attr->{NAME};
$info->{version} = $dist_attr->{VERSION};
return() if not defined $info->{name} or not defined $info->{version};
$info->{version} =~ s/,/./g;
$info->{version} =~ s/(?:\.0)+$//;
while (@$children) {
my $tag = shift @$children;
# Skip any direct content
shift(@$children), next if $tag eq '0';
if ($tag =~ /^implementation$/i) {
my $impl = _parse_implementation(shift @$children);
push @{$info->{implementations}}, $impl if defined $impl;
}
elsif ($tag =~ /^dependency$/i) {
my $dep = _parse_dependency(shift @$children);
push @{$info->{deps}}, $dep if defined $dep;
}
elsif ($tag =~ /^title$/i) {
$info->{title} = shift(@$children)->[2];
}
elsif ($tag =~ /^abstract$/i) {
$info->{abstract} = shift(@$children)->[2];
}
elsif ($tag =~ /^author$/i) {
$info->{author} = shift(@$children)->[2];
}
elsif ($tag =~ /^license$/i) {
$info->{license} = shift(@$children)->[0]{HREF};
}
else {
shift @$children;
}
}
return $info;
}
sub _parse_dependency {
my $content_ary = shift;
return(); # XXX currently unused and hence not implemented
}
sub _parse_implementation {
my $impl_ary = shift;
my $impl = {
deps => [],
os => [],
arch => undef,
uri => undef,
processor => undef,
language => undef,
osversion => undef,
perl => undef,
};
my $c = $impl_ary;
shift @$c; # skip attributes
while (@$c) {
my $tag = shift @$c;
if ($tag eq '0') {
shift @$c;
}
elsif ($tag =~ /^language$/i) {
$impl->{language} = shift(@$c)->[2];
}
elsif ($tag =~ /^os$/i) {
my $attr = shift(@$c)->[0];
push @{$impl->{os}}, $attr->{VALUE} || $attr->{NAME};
}
elsif ($tag =~ /^osversion$/i) {
my $attr = shift(@$c)->[0];
$impl->{osversion} = $attr->{VALUE} || $attr->{NAME};
}
elsif ($tag =~ /^perlcore$/i) {
my $attr = shift(@$c)->[0];
$impl->{perl} = $attr->{VERSION};
}
elsif ($tag =~ /^processor$/i) {
my $attr = shift(@$c)->[0];
$impl->{processor} = $attr->{VALUE} || $attr->{NAME};
}
elsif ($tag =~ /^architecture$/i) {
my $attr = shift(@$c)->[0];
$impl->{arch} = $attr->{VALUE} || $attr->{NAME};
}
elsif ($tag =~ /^codebase$/i) {
my $attr = shift(@$c)->[0];
push @{$impl->{uri}}, $attr->{HREF} || $attr->{FILENAME};
}
elsif ($tag =~ /^dependency$/i) {
my $dep = _parse_dependency(shift @$c);
push @{$impl->{deps}}, $dep if defined $dep;
}
else {
shift @$c;
}
}
return $impl;
}
sub _override_info {
my $info = shift;
my $arg_map = shift;
my $args = shift;
foreach my $arg (keys %$arg_map) {
next if not defined $args->{$arg};
my $to = $arg_map->{$arg};
if (ref($to)) {
my $ary = $info->{shift(@$to)};
$ary->[$_]{$to->[0]} = $args->{$arg} for 0..$#$ary;
}
else {
$info->{$to} = $args->{$arg};
}
}
}
1;
__END__
=head1 NAME
PAR::Dist::FromPPD - Create PAR distributions from PPD/PPM packages
=head1 SYNOPSIS
use PAR::Dist::FromPPD;
# Creates a .par distribution of the PAR module in the
# current directory based on the PAR.ppd file from the excellent
# bribes.org PPM repository.
ppd_to_par(uri => 'http://www.bribes.org/perl/ppm/PAR.ppd');
# You could download the .ppd and .tar.gz files first and then do:
ppd_to_par(uri => 'PAR.ppd', verbose => 1);
=head1 DESCRIPTION
This module creates PAR distributions from PPD XML documents which
are used by ActiveState's "Perl Package Manager", short PPM.
It parses the PPD document to extract the required
information and then uses PAR::Dist to create a .par archive from it.
Please note that this code I<works for me> but hasn't been tested
to full extent.
=head2 EXPORT
By default, the C<ppd_to_par> subroutine is exported to the callers
namespace. C<get_ppd_content> will be exported on demand.
=head1 SUBROUTINES
This is a list of all public subroutines in the module.
=head2 ppd_to_par
The only mandatory parameter is an URI for the PPD file to parse.
Arguments:
uri => 'ftp://foo/bar' or 'file:///home/you/file.ppd', ...
out => 'directory' (write distribution files to this directory)
verbose => 1/0 (verbose mode on/off)
distname => Override the distribution name
distversion => Override the distribution version
perlversion => Override the distribution's (minimum?) perl version
arch => Override the distribution's target architecture
selectarch => Regular Expression.
selectperl => Regular Expression.
C<arch> may also be set to C<any_arch> and C<perlversion> may be set to
C<any_version>.
If a regular expression is specified using C<selectarch>, that expression is
matched against the architecture settings of each implementation. The first
matching implementation is chosen. If none matches, the implementations
are tried in order of appearance. Of course, this heuristic is applied before
any architecture overriding via the C<arch> parameter is carried out.
C<selectperl> works the same as C<selectarch>, but operates on the (minimum)
perl version of an implementation. If both C<selectperl> and C<selectarch>
are present, C<selectperl> operates on the implementations matched by
C<selectarch>. That means C<selectarch> takes precedence.
=head2 get_ppd_content
First argument must be an URI string for the PPD.
(Supported are C<file://> URIs and whatever L<LWP>
supports.)
Fetches the PPD file and returns its contents as a string.
C<die()>s on error.
=head1 SEE ALSO
The L<PAR::Dist> module is used to create .par distributions from an
unpacked CPAN distribution. The L<CPAN> module is used to fetch the
distributions from the CPAN.
PAR has a mailing list, <par@perl.org>, that you can write to; send an empty mail to <par-subscribe@perl.org> to join the list and participate in the discussion.
Please send bug reports to <bug-par-dist-fromppd@rt.cpan.org>.
The official PAR website may be of help, too: http://par.perl.org
For details on the I<Perl Package Manager>, please refer to ActiveState's
website at L<http://activestate.com>.
=head1 AUTHOR
Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2006 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

215
database/perl/vendor/lib/PAR/Dist/InstallPPD.pm vendored Normal file
View File

@@ -0,0 +1,215 @@
package PAR::Dist::InstallPPD;
use 5.006;
use strict;
use warnings;
use PAR::Dist::FromPPD ();
use PAR::Dist ();
use File::Temp ();
use File::Spec;
use File::Path;
use Cwd;
require Config;
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(
par_install_ppd
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
par_install_ppd
);
our $VERSION = '0.02';
our $VERBOSE = 0;
sub _verbose {
$VERBOSE = shift if (@_);
return $VERBOSE
}
sub _diag {
my $msg = shift;
return unless _verbose();
print $msg ."\n";
}
sub par_install_ppd {
die "Uneven number of arguments to 'par_install_ppd'." if @_ % 2;
my %args = @_;
_verbose($args{'verbose'});
_diag "Creating temporary directory for temporary .par";
my $tdir = $args{out} = File::Temp::tempdir(
CLEANUP => 1,
DIR => File::Spec->tmpdir(),
);
_diag "Preparing meta data for temporary .par";
# should be figured out by ::FromPPD
delete $args{$_} for qw(
distversion perlversion
);
# just need to be defined.
$args{arch} = $Config::Config{archname};
$args{perlversion} = sprintf('%vd', $^V);
# Accept running perl version (5.8.8)
# or main perl version (5.8)
# or any other subversions (5.8.6)
my $perlver = sprintf('%vd', $^V);
my $mainperlver = $perlver;
$mainperlver =~ s/^(\d+)\.(\d+)\..*$/$1.$2/;
_diag "Setting perl version to ($perlver|$mainperlver|$mainperlver\\.\\d+)"
if not defined $args{selectperl};
$args{selectperl} ||= qr/^(?:$perlver|$mainperlver|$mainperlver\.\d+)$/;
# Accept running arch
my $arch = quotemeta( $Config::Config{archname} );
_diag "Setting architecture to $Config::Config{archname}"
if not defined $args{selectarch};
my $perlver_nodots = $mainperlver;
$perlver_nodots =~ s/\.//g;
$args{selectarch} ||= qr/^(?:$arch-?(?:$perlver_nodots\d*|$mainperlver(?:\.\d+)?)|$arch)$/;
_diag "Using temporary directory $tdir.";
_diag "Invoking PAR::Dist::FromPPD to create the .par file.";
PAR::Dist::FromPPD::ppd_to_par(%args);
_diag "Searching for generated .par file.";
_diag "chdir() to '$tdir'";
my $cwd = Cwd::cwd();
chdir($tdir);
opendir my $dh, '.' or die $!;
my @par_files = grep {-f $_ and /\.par$/i} readdir($dh);
_diag "Found PAR files: @par_files.";
_diag "Installing PAR files.";
foreach my $file (@par_files) {
_diag "Installing file '$file' with PAR::Dist::install_par().";
PAR::Dist::install_par($file);
}
_diag "Done installing PAR files.";
chdir($cwd);
File::Path::rmtree([$tdir]);
return(1);
}
1;
__END__
=head1 NAME
PAR::Dist::InstallPPD - Installs PPM packages the PAR way
=head1 SYNOPSIS
use PAR::Dist::InstallPPD;
# Creates a .par distribution of the Tk module in the
# current directory based on the Tk.ppd file from the excellent
# bribes.org PPM repository.
par_install_ppd(uri => 'http://www.bribes.org/perl/ppm/Tk.ppd');
# You could download the .ppd and .tar.gz files first and then do:
par_install_ppd(uri => 'Tk.ppd', verbose => 1);
=head1 DESCRIPTION
This module creates PAR distributions from PPD XML documents which
are used by ActiveState's "Perl Package Manager", short PPM.
Then, it installs these newly created temporary F<.par> files in the
default location using L<PAR::Dist>'s C<install_par> routine.
Yes, that means you can install packages for the PPM without PPM.
The module uses L<PAR::Dist::FromPPD> to create the F<.par> files.
Please note that this code I<works for me> but hasn't been tested
to full extent.
=head2 EXPORT
By default, the C<par_install_ppd> subroutine is exported to the caller's
namespace.
=head1 SUBROUTINES
This is a list of all public subroutines in the module.
=head2 par_install_ppd
This routine takes the same arguments as C<ppd_to_par> from
L<PAR::Dist::FromPPD> except for the output directory and the
options that set the meta data for the produced F<.par> file.
The details are reproduced below.
The only mandatory parameter is an URI for the PPD file to parse.
Arguments:
uri => 'ftp://foo/bar' or 'file:///home/you/file.ppd', ...
verbose => 1/0 (verbose mode on/off)
selectarch => Regular Expression.
selectperl => Regular Expression.
If a regular expression is specified using C<selectarch>, that expression is
matched against the architecture settings of each implementation. The first
matching implementation is chosen. If none matches, the implementations
are tried in order of appearance.
C<selectperl> works the same as C<selectarch>, but operates on the (minimum)
perl version of an implementation. If both C<selectperl> and C<selectarch>
are present, C<selectperl> operates on the implementations matched by
C<selectarch>. That means C<selectarch> takes precedence.
=head1 SEE ALSO
The L<PAR::Dist> module is used to create L<.par> distributions and install
them. The L<PAR::Dist::FromPPD> module converts the PPD package descriptions.
PAR has a mailing list, <par@perl.org>, that you can write to; send an empty mail to <par-subscribe@perl.org> to join the list and participate in the discussion.
Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>.
The official PAR website may be of help, too: http://par.perl.org
For details on the I<Perl Package Manager>, please refer to ActiveState's
website at L<http://activestate.com>.
=head1 AUTHOR
Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2006 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

237
database/perl/vendor/lib/PAR/Environment.pod vendored Normal file
View File

@@ -0,0 +1,237 @@
=head1 NAME
PAR::Environment - Index and reference of PAR environment variables
=head1 DESCRIPTION
PAR uses various environment variables both during the building process of
executables or PAR archives and the I<use> of them. Since the wealth of
combinations and settings might confuse one or the other (like me), this
document is intended to document all environment variables which PAR uses.
Wherever I want to refer to the C<$ENV{FOO}> environment hash entry, I will
usually talk about the C<FOO> variable for brevity.
=head1 INDEX OF ENVIRONMENT VARIABLES
B<Please note that this is still very, very incomplete! Contributions welcome!>
For each variable, there should be a description what it contains, when
it can be expected to exist (and contain meaningful information),
when it is sensible to define it yourself, and what effect this has.
Of course, the description may use examples.
=head2 PAR_0
If the running program is run from within a PAR archive or pp-produced
executable, this variable contains the name of the extracted program
(i.e. .pl file). This is useful of you want to open the source code
file of the running program.
For example, if you package a file F<foo.pl> into
F<bar.par> and run F<foo.pl> with this command
par.pl foo.par bar.pl
then the C<PAR_0> variable will contain something like
C</tmp/par-youser/cache-b175f53eb731da9594e0dde337d66013ddf25a44/495829f0.pl>
where C<youser> is your username and
C</tmp/par-youser/cache-b175f53eb731da9594e0dde337d66013ddf25a44/> is the
PAR cache directory (C<PAR_TEMP>).
The name of the PAR cache directory can take a number of different forms,
so use C<PAR_0> if you want to find the extracted program's .pl file --
attempting to construct the name yourself requires complex logic that
has already produced the value in C<PAR_0>.
This works the same for executable binaries (F<.exe>, ...).
If you are looking for the name and path of the pp-ed binary file,
please refer to the C<PAR_PROGNAME> variable.
=head2 PAR_CLEAN
Users should set C<PAR_GLOBAL_CLEAN> instead.
Recreated from C<PAR_GLOBAL_CLEAN> and the value of C<-C> from the YAML file
by the PAR loader, and used within loader to control the initial behavior
of extraction, and the final behavior of cleanup. The user can reference
C<PAR_CLEAN> in the application to determine which of these behaviors
is being used for this run of the application.
=head2 PAR_DEBUG
Users should set C<PAR_GLOBAL_DEBUG> instead.
If this variable is set to a true value and F<par.pl> is run,
verbose output is sent to STDOUT or the logging filehandle.
This is overridden by the C<-q> option to F<par.pl>,
for steps after argument parsing occurs.
This currently only influences F<par.pl>. Whether this is the intended
behaviour remains to be verified.
=head2 PAR_GLOBAL_CLEAN
Setting C<PAR_GLOBAL_CLEAN> alters the behavior of par applications
which see that environment variable at launch.
C<PAR_GLOBAL_CLEAN> overrides the C<-C> option.
Settings of 0 and 1 are supported. 0 corresponds to not using C<-C> on the
pp command line; 1 corresponds to using C<-C> on the pp command line.
C<PAR_GLOBAL_CLEAN> is ignored if C<PAR_GLOBAL_TEMP> is set, yet it
controls the form of C<PAR_TEMP> when C<PAR_GLOBAL_TEMP> is not set.
=head2 PAR_GLOBAL_DEBUG
The PAR loader becomes more verbose when C<PAR_DEBUG> is set.
Setting C<PAR_GLOBAL_DEBUG> guarantees that C<PAR_DEBUG> will be set
internally, initially. See C<PAR_DEBUG> for more details.
=head2 PAR_GLOBAL_TEMP
Contributes to the calculation of C<PAR_TEMP>, and is further explained
there.
=head2 PAR_GLOBAL_TMPDIR
Contributes to the calculation of C<PAR_TEMP>, and is further explained
there.
=head2 PAR_INITIALIZED
This environment variable is for internal use by the PAR binary loader
only.
Documented only to avoid surprises if spawned applications expect
to see a value initialized by the user.
=head2 PAR_PROGNAME
C<PAR_PROGNAME> is set to the fully-qualified path name of the executable
program.
On Windows, this is reliably obtained from the C<GetModuleFileName> API.
On other OSes, if the C runtime is given a qualified path name, it is used,
or the unqualified file name given is qualified by walking the path.
This is reasonably reliable given normal program spawning conventions,
but cannot be guaranteed to be correct in all circumstances.
=head2 PAR_APP_REUSE
Strictly internal. Skip this section if you're not a PAR developer.
The variable shouldn't ever be exposed to user code and packaged
applications should not depend on it being set or not.
If an application has been packaged with the C<--reusable> option, the
bootstrapping code will set this environment variable to the name of
the program that is to be run instead of the packaged program.
The F<main.pl> loader script fetches the file name, deletes the
environment variable, and then runs the given program.
=head2 PAR_RUN
This environment variable was set during constructions of C<PAR::Packer>
objects (usually during F<pp> runs only) by versions of PAR up to
0.957. Since PAR 0.958, this variable is unused.
=head2 PAR_SPAWNED
This variable is used internally by the F<parl> binary loader to signal
the child process that it's the child.
You should not rely on this variable outside of the PAR binary loader
code. For a slightly more detailed discussion, please refer to the
F<who_am_i.txt> documentation file in the PAR source distribution
which was contributed by Alan Stewart.
Documented only to avoid surprises if spawned applications expect
to see a value initialized by the user.
=head2 PAR_TEMP
Users should set C<PAR_GLOBAL_TEMP> instead.
C<PAR_TEMP> is calculated from a variety of other variables.
See the C<NOTES> section in the pod for PAR.pm for
a complete description of how the calculation proceeds.
C<PAR_TEMP>, once calculated, is used as the location
where PAR stores its extracted, temporary file cache.
=head2 PAR_TMPDIR
Contributes to the calculation of C<PAR_TEMP>, and is further explained
there. Users should set C<PAR_GLOBAL_TMPDIR> instead.
=head2 PAR_VERBATIM
The C<PAR_VERBATIM> variable controls the way Perl code is packaged
into a PAR archive or binary executable. If it is set to a true
value during the packaging process, modules (and scripts) are
B<not> passed through the default C<PAR::Filter::PodStrip> filter
which removes all POD documentation from the code. Note that the
C<PAR::Filter::PatchContent> filter is still applied.
The C<-F> option to the F<pp> tool overrides the C<PAR_VERBATIM>
setting. That means if you set C<PAR_VERBATIM=1> but specify
C<-F PodStrip> on the C<pp> command line, the C<PodStrip> filter
will be applied.
C<PAR_VERBATIM> is not used by the PAR application.
=head2 PAR_VERBOSE
Setting this environment variable to a positive integer
has the same effect as using the C<-verbose> switch to F<pp>.
=head2 PP_OPTS
During a F<pp> run, the contents of the C<PP_OPTS> variable are
treated as if they were part of the command line. In newer versions
of PAR, you can also write options to a file and execute F<pp>
as follows to read the options from the file:
pp @FILENAME
That can, of course, be combined with other command line arguments
to F<pp> or the C<PP_OPTS> variable.
=head2 TMP, TEMP, TMPDIR, TEMPDIR
Please refer to C<PAR_TMPDIR>.
=head1 SEE ALSO
L<PAR>, L<PAR::Tutorial>, L<PAR::FAQ>
L<par.pl>, L<parl>, L<pp>
L<PAR::Dist> for details on PAR distributions.
=head1 AUTHORS
Steffen Mueller E<lt>smueller@cpan.orgE<gt>
You can write
to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty mail to
E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
Please submit bug reports to E<lt>bug-par@rt.cpan.orgE<gt>. If you need
support, however, joining the E<lt>par@perl.orgE<gt> mailing list is
preferred.
=head1 COPYRIGHT
PAR: Copyright 2003-2010 by Audrey Tang,
E<lt>cpan@audreyt.orgE<gt>.
This document: Copyright 2006-2010 by Steffen Mueller,
E<lt>smueller@cpan.orgE<gt>
Some information has been taken from Alan Stewart's extra documentation in the
F<contrib/> folder of the PAR distribution.
This program or documentation is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F<LICENSE>.
=cut

351
database/perl/vendor/lib/PAR/FAQ.pod vendored Normal file
View File

@@ -0,0 +1,351 @@
=encoding utf8
=head1 NAME
PAR::FAQ - Frequently Asked Questions about PAR
=head1 SYNOPSIS
This is the Frequently Asked Questions list for the Perl Archive Toolkit.
This (included) FAQ list might be outdated. The Wiki version at the above URL
is guaranteed to be up to date.
=head1 DESCRIPTION
=head2 Where is the Windows binary version?
You can find windows binaries here:
L<http://www.cpan.org/authors/id/S/SM/SMUELLER/>
There are three ways to install them. Sorted in order of preference:
=head3 cpan
Run the I<cpan> command line tool that comes with Perl. In the I<cpan> shell, type
install PAR
and wait for the script to download and extract PAR and its dependencies. If you have a C compiler installed, PAR will be built on your computer for your specific version of Perl. If you do not have a C compiler, the installer will look at the site referenced above for a compatible binary release and ask you whether you would like to install it.
=head3 ppm
If you are using ActivePerl from ActiveState, you can use the 'ppm' program that comes with the ActiveState Perl. Instructions can be found below. PAR is available from various PPM repositories and some packages are compatible with some versions of ActivePerl and not with others. There is an incomplete PAR-Win32 Binary Compatibility List at L<http://par.wikia.com/wiki/PAR_PPM_Compatibility_List> There are at least three relevant PPM repositories: The default ActiveState one, the bribes repository which is used in the example below and Randy Kobes' repository at L<http://theoryx5.uwinnipeg.ca/ppms/>.
C:\> ppm3
# activestate was out of date compared to this one
% rep add bribes http://www.bribes.org/perl/ppm
# move it to first place on list of repositories
% rep up bribes
CPAN>upgrade -install PAR
And finally, 'q' to quit and that's all :-) You have access to pp and so on...
=head3 manual
For reference, here's the old explanation of how to install it by hand:
The file you need will be called PAR-X.XX-MSWin32-x86-multi-thread-Y.Y.Y.par where X.XX is the version of PAR you will use and Y.Y.Y is the version of Perl you have. Unzip this file (you may need to rename it to end with .zip instead of .par first) and copy all the files in the script directory into a directory in your PATH. Now you should be able to use PAR.
=head2 Can PAR bundle all its prerequisites?
I<Note:> This entry needs serious attention.
Yes and no.
It would be possible to do this but it would also introduce a maintenance nightmare. A new version of PAR would have to be released whenever a new version of any of the dependencies came out. This is already painful with the included L<Module::Install>.
The original proposal which led to this FAQ entry considered the case where you want to install PAR without a working CPAN.pm/CPAN shell installation or without internet connectivity. By default, PAR will try to install its dependencies from CPAN using the CPAN.pm module.
Given that you have a development machine with PAR installed and with a working CPAN.pm, it is reasonably simple to create one or more .par distributions of PAR's dependencies. Install L<PAR::Dist::FromCPAN>. Then you can create .par distributions (read: binaries installable with the pure-perl PAR::Dist on the same architecture) for the PAR dependencies as follows:
mkdir par_files
cpan2par --pattern PAR --follow --out par_files/ --merge --skip File::.*
--skip Getopt::Std --skip Carp --skip Data::Dumper --skip Time::Local
--skip 'Test\b.*' --skip Text::ParseWords --skip ExtUtils::.*
--skip Getopt::Long --skip Text::Abbrev --skip DirHandle --skip Pod::.*
(Line breaks inserted for readability.) What happens here? cpan2par uses the API of the CPAN.pm module to fetch the PAR distribution from CPAN, unpacks it, builds it, creates a .par archive from its compiled state and then does the same for any of its dependencies. And then for its dependencies dependencies and... You get the idea. This is what the --follow option does. We add a couple of --skip options to skip core modules which we need not include and any Test::* modules. The --merge option merges all of the .par distributions into the original PAR one. Voila! (Future versions of PAR::Dist::FromCPAN might include an option --skip-core which would skip any modules contained in the core distribution.)
After this command worked its magic, you should have a single file PAR-VERSION-ARCHNAME-PERLVERSION.par in the subdirectory 'par_files/'. You can now install PAR and its non-core dependencies on any machine that has the architecture of your development system (and a binary compatible perl version) using L<PAR::Dist> as follows:
perl -MPAR::Dist -einstall_par
Provided that you run the command from within the directory containing the aforementioned .par file (and no other .par file).
Since you might not even have PAR::Dist on the target machine, you can do this simple hack to get a basic installer:
perl -MPAR::Dist -e'open my $fh, "<", $INC{"PAR/Dist.pm"}; print <$fh>;
print "\npackage main;\nPAR::Dist::install_par(\@ARGV ? shift(\@ARGV)
: ());\n\n"'
> installer.pl
(Again: Line breaks inserted for readability.) This looks for your installed copy of PAR::Dist, reads it, writes it to STDOUT and appends two lines of code: "package main;" and a call to PAR::Dist::install_par. By default, it will install any (single) .par file in the current directory. If supplied with a file name as first argument, it will install the specified file. It should have no non-core dependencies! So shipping the generated PAR-....par file and the installer.pl file to the target machine and running "perl installer.pl" should just magically install PAR and its dependencies for you.
Now, this whole trick works equally well for any other modules. In fact, if you have PAR on the target machine, you needn't even install the modules in the .par file in order to use them! You can just add "use PAR 'foo-bar.par';" to your code and any modules will be loaded from the .par file as necessary. ("perl -MPAR=foo-bar.par your_script.pl" works, too.) The documentation of the PAR module has details on this.
Finally, note that you can install L<PAR::Repository::Client> on the target machines and subsequently use PAR 0.951 and later to automatically fetch any unfulfilled dependencies from a (remote or local) repository:
use PAR { repository => 'http://my_local_secure_host/repository' };
or:
use PAR { repository => 'file:///path/to/repository' };
Details, again, in the L<PAR> documentation and in the L<PAR::Repository::Client> documentation.
Answer from: Steffen Mueller, 16 August 2006
=head2 If I try to compile my wxGlade generated script, it doesn't run. What's wrong?
I<Note:> Is this still a problem?
Comment out the line that starts with " unless (caller) ", and compile it again. Note that this is considered a bug; clearing the caller stack is a development in progress.
=head2 I get a link error '/usr/bin/ld: cannot find -lperl' during the 'make' step of the installation on Debian. What's wrong?
Install the C<libperl-dev> package.
Note that Debian provides (usually up-to-date) packages of the modules
in the PAR ecosystem: L<Module::Scandeps>, L<PAR>,
L<PAR::Dist> and L<PAR::Packer>; the corresponding packages are called
C<libmodule-scandeps-perl>, C<libpar-dist-perl>, C<libpar-perl>
and C<libpar-packer-perl>.
=head2 I added a directory to my PAR file using "zip -r" or winzip, and then generated an executable from this PAR file, and the executable failed to run (IO error: reading header signature :..). What's wrong?
As pointed out by Alan Stewart, zip adds a directory entry for the new directory, and it causes the PAR executable to fail. Just use :
zip -r -D hello.par my_dir/
or the Archive::Zip::addTree as follows :
$zip->addTree( $root, $dest, sub { -f } )
=head2 On what platforms can I run PAR? On what platforms will the resulting executable run?
Win32 (95/98/ME/NT4/2K/XP), FreeBSD, Linux, AIX, Solaris, Darwin and Cygwin.
The resulting executable will run on any platforms that supports the binary format of the generating platform.
=head2 How do I extract my script out of packed executable?
In other words, "I did a `pp foo.pl' and I lost foo.pl, how do I get it back?".
The answer is to just use unzip/winzip/winrar/whatever to decompress the executable, treating it like a normal Zip file. You may need to rename the executable into a .zip extension first.
=head2 Can PAR completely hide my source code?
Not completely, but possible to a degree. Starting from version 0.76, PAR supports an input filter mechanism, which can be used to implement source obfuscators (or even product activation schemes).
But if you are looking for 100% bulletproof way of hiding source code, it is not possible with any language. Learning Perl, 3rd Edition has this answer to offer (quoted with permission from Randal Schwartz):
If you're wishing for an opaque binary, though, we have to tell
you that they don't exist. If someone can install and run your
program, they can turn it back into source code. Granted, this
won't necessarily be the same source that you started with, but
it will be some kind of source code. The real way to keep your
secret algorithm a secret is, alas, to apply the proper number
of attorneys; they can write a license that says "you can do
this with the code, but you can't do that. And if you break our
rules, we've got the proper number of attorneys to ensure that
you'll regret it."
Other than that, I would point you at L<PAR::Filter::Crypto>. Be sure to read the CAVEATS and WARNINGS sections of the documentation.
=head2 On Windows XP, pp crashes saying that "par.exe has encountered a problem"
This is believed to be fixed by PAR 0.76_99. The following answer applies to PAR 0.76 and earlier:
You may be able to escape this problem by setting some executables to Windows 95 compatibility mode. Specifically, find "parl.exe" (probably in "C:\perl\5.8.0\bin") using Windows Explorer, and right-click on it and choose "Properties". Choose the "Compatibility" tab and tick the box for "Run this program with compatibility mode for" and check that the dropdown shows "Windows 95". Then click OK.
Now you can hopefully run pp as normal to generate an EXE. Before you can run the generated EXE, you'll need to set its compatibility mode too, in the same way as you did for parl.exe.
This workaround is known not to work in all cases, and the developers are working on a solution to the problem. See these posts for more info:
L<http://www.mail-archive.com/par@perl.org/msg00423.html>,
L<http://www.mail-archive.com/par@perl.org/msg00435.html>,
L<http://www.mail-archive.com/par@perl.org/msg00573.html>,
L<http://www.mail-archive.com/par@perl.org/msg00670.html>
=head2 Perl Tk tips
On Windows XP start your script with
use strict; use Encode::Unicode; use Tk;
Some widgets use xbm bitmaps which don't get picked up by PAR. The error is:
couldn't read bitmap file "": No such file or directory
error reading bitmap file "" at Tk/Widget.pm line 205.
at Tk/Widget.pm line 203
Fix is to find the missing xbm files (perl -V tells you where to start looking) and add them to the executable eg
copy missing xbm files to script directory then:
% pp --add cbxarrow.xbm --add arrowdownwin.xbm -o test test.pl
=head2 Problem with Win32::Perms and Perms.DLL
With a script my.pl using Win32::Perms, pp -o my.exe my.pl you may have:
Can't locate loadable object for module Win32::Perms in @INC
(@INC contains: CODE(0xb97eec) CODE(0xc8a99c) .)
at ../blib/lib/PAR/Heavy.pm line 78
In fact the dll is Perms.DLL wit DLL in capital letters. That's the problem. The bootstrap function of PAR in the Dynaloader module fails looking for Perms.dll in the table of dlls which contains only Perms.DLL. And so the solution is just rename Perms.DLL in Perms.dll and do pp -o my.exe my.pl ... and everything goes right.
=head2 Under Win32, a pp packed executable has trouble executing other perl scripts or pp packed executable
I<Note:> Is this still current?
When running on a Win32 system, if a perl script is packed with pp and invokes another Perl script or pp packed executable, either with system() or backticks, the invoked program runs with the copy of perl5x.dll already loaded into memory. If the calling executable was packed with "pp -d", the perl5x.dll is the one from the installed perl bin directory. Otherwise, it is the one packed with the executable. The perl5x.dll from the bin dir knows the @INC paths for the installed libraries; the one in the executable does not. Because of this, a program packed without "-d" calling a program with packed with "-d" or calling perl.exe to run a plain Perl script may fail. This is a Win32 limitation.
=head2 How can I make a .exe that runs with no console window under Windows?
Use the --gui switch, ie
% pp --gui -o file.exe file.pl
I found that this is not documented on all versions of pp ... Some versions have a more complete doc than others when you type "pp -h" etc. (This should be reasonably documented now.)
When searching for an answer to this myself, I found many references to using "exetype" ... it comes as a .bat with ActivePerl, or you can find an exetype.pl from several places. You run "exetype file.exe [WINDOWS|CONSOLE]". This worked, I think, but still did not achieve the desired result on my PAR executable. While the exe itself did not generate a console window, par.exe (which was invoked in my exe somewhere) DID generate a console window, with a titlebar saying "par.exe <strange-looking path to file in temp dir>", whereas before changing the console window title bar just displayed the path to my .exe.
=head2 The command line parameters (@ARGV) of a pp-ed binary called from another pp-ed binary are missing or broken. What the...?
This was a bug in releases up to and including PAR-0.90. Please upgrade to PAR 0.91 or later and the problem will go away.
=head2 I want to include a pp-ed binary in an RPM package. How can I make this work?
The binary executables outputted by pp (on Linux) are not valid ELF binaries because it basically attaches a zip archive to the binary loader and does not modify the ELF headers to reflect that. When building an RPM archive, the validity of the ELF headers is checked by default. This can result in problems when packaging pp-ed binaries in RPM archives.
Scott McBrien helped track down what can be done to get this to work:
[I]t appears that the RPM archive that is generated gets a list of
the MD5 sums for components of the executable file calculated by
prelink. By disabling prelink, it fixed the problem; in my RPM .spec
file:
%define __prelink_undo_cmd %{nil}
After quite some time, it seems like the smart folks at Redhat found the culprit. I'm glad *they* did, because I wouldn't have:
It appears that we found a solution that works. It like the pp
executables are already stripped, so we don't want rpm stripping them
again, which, of course, renders them useless.
In this case, we added the following lines to the spec file to keep rpm
from running the strip process and not produce debuginfo packages:
%define __spec_install_post :
%define debug_package %{nil}
Don't forget to add the ":" character to __spec_install_post as above or
this won't work.
Much praise to all who helped track this down! The discussion can be found in the following RT tickets:
L<http://rt.cpan.org/Public/Bug/Display.html?id=18536|#18536> and L<http://rt.cpan.org/Public/Bug/Display.html?id=19609|#19609>.
-- Steffen Mueller, 22 July 2006
=head2 How can I package Wx applications?
Have a look at the separately maintained L<Wx::Perl::Packager> module.
-- Steffen Mueller, 3 July 2006
=head2 How can I package Catalyst web applications?
Catalyst has some builtin PAR support. I found the following URL to be very helpful:
L<http://catalyst.infogami.com/cookbook/par>.
-- Steffen Mueller, 21 July 2006
=head2 The resulting files are huge! How can I reduce the size of the output file?
The executables generated by pp generally contain a copy of your Perl shared libraries, the Perl core modules and any module dependencies your packaged application may have. That is a lot. Sometimes, PAR packages too much. It adheres to the philosophy of rather making the application work than generating a streamlined executable. If you want to optimize this, you will have to do so by excluding specific modules.
Chris Dolan's recent post to the PAR mailing list explains this well. Quoting Chris: (L<http://www.nntp.perl.org/group/perl.par/2490>)
[...]
I've found a few tricks that can help a lot:
* If you know the target platform has Perl pre-installed (e.g. Mac OS X)
then use the "--dependent" flag. This skips all of the core modules,
yielding a much smaller executable.
One significant caveat is moving to older systems. For example,
Mac OS X 10.2 had Perl 5.6.0 which has 146 fewer core modules than
Perl 5.8.6 which shipped with Mac OS X 10.4, and (even more significantly)
is binary-incompatible with any extra XS modules added from CPAN.
Other platforms can be even harder to predict.
* Watch for modules that pull in lots of dependencies
A good example is DBI. If your program uses DBI, then Module::ScanDeps
pulls in ALL of the DBD::* modules (some of which are large) installed on
your system, because it cannot realistically parse the DBI->connect()
arguments which specify which database drivers are actually needed.
In one of my MySQL-based applications, I use this invocation of PAR:
pp -X DBD::SQLite -X DBD::CSV -X DBD::File -X DBD::Excel
which saves quite a few bytes, because both DBD::SQLite and DBD::Excel
have lots of CPAN dependencies. The actual list if DBD::* modules you
need to exclude depends on your system. Here's a short command that will
reveal all DBD::* modules on a unix-like system:
perl -MModule::ScanDeps -le'print for map {"DBD/".$_->{name}} Module::ScanDeps::_glob_in_inc("DBD")'
Another smaller example is SOAP::Transport::* where most installations
only need SOAP::Transport::HTTP.
[...]
Similar techniques can be applied when a module makes use of L<Module::Pluggable> for plugins.
Finally, there is a PAR filter available as a separate distribution on CPAN which compresses the source code as much as possible by first parsing it using PPI and then spitting out a reduced functional equivalent:
L<PAR::Filter::Squish>.
-- Steffen Mueller, August 2006
=head2 How do I use Win32::GUI::SplashScreen with PAR?
When using pp to package an application that uses Win32::GUI::SplashScreen, try adding the splashscreen bitmap manually as suggested in the Win32::GUI::SplashScreen docs:
pp -a SPLASHFILE.bmp -o xxx.exe xxx.pl
=head2 The Perl Packager scripts says that it can create executable that runs in same OS. Can I use it to create Win32 binary with linux machine? Or what should I use to create Win32 executable binary on linux from my script?
It is not possible to create stand-alone binaries for different platform than what you are currently running on. This is a generally hard problem since you would have to cross-compile all XS modules and perl itself. Not nice.
For example, if you would like to develop an application on Linux and ship it for both Linux/x86 and Win32/x86, it works well to set up a Virtual Machine with a Windows (XP or 2000 or whatever) and a Perl installation. On that machine, use PAR/pp to package your application for Win32.
See also the question "On what platforms can I run PAR? On what platforms will the resulting executable run?".
-- Steffen Mueller, 2 November 2006
=head1 SEE ALSO
L<PAR>, L<PAR::Tutorial>
=head1 AUTHORS
Audrey Tang E<lt>cpan@audreyt.orgE<gt>,
Steffen Mueller E<lt>smueller@cpan.orgE<gt>
You can write
to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty mail to
E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
Please submit bug reports to E<lt>bug-par@rt.cpan.orgE<gt>.
=head1 COPYRIGHT
Copyright 2003-2008 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
This document is free documentation; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<LICENSE>.
=cut

200
database/perl/vendor/lib/PAR/Heavy.pm vendored Normal file
View File

@@ -0,0 +1,200 @@
package PAR::Heavy;
$PAR::Heavy::VERSION = '0.12';
=head1 NAME
PAR::Heavy - PAR guts
=head1 SYNOPSIS
(internal use only)
=head1 DESCRIPTION
No user-serviceable parts inside.
=cut
########################################################################
# Dynamic inclusion of XS modules
# NOTE: Don't "use" any module here, esp. one that is an XS module or
# whose "use" could cause the loading of an XS module thru its dependencies.
# enable debug/trace messages from DynaLoader perl code
my $dl_debug = $ENV{PERL_DL_DEBUG} || 0;
my ($bootstrap, $dl_findfile); # Caches for code references
my ($cache_key); # The current file to find
my $is_insensitive_fs = (
-s $0
and (-s lc($0) || -1) == (-s uc($0) || -1)
and (-s lc($0) || -1) == -s $0
);
# Adds pre-hooks to Dynaloader's key methods
sub _init_dynaloader {
return if $bootstrap;
return unless eval { require DynaLoader; DynaLoader::dl_findfile(); 1 };
print STDERR "PAR::Heavy: pre-hooks to Dynaloader's key methods\n"
if $dl_debug;
$bootstrap = \&DynaLoader::bootstrap;
$dl_findfile = \&DynaLoader::dl_findfile;
local $^W;
*{'DynaLoader::dl_expandspec'} = sub { return };
*{'DynaLoader::bootstrap'} = \&_bootstrap;
*{'DynaLoader::dl_findfile'} = \&_dl_findfile;
}
# Return the cached location of .dll inside PAR first, if possible.
sub _dl_findfile {
print STDERR "PAR::Heavy::_dl_findfile($cache_key)\n" if $dl_debug;
if (exists $FullCache{$cache_key}) {
print STDERR " found in FullCache as $FullCache{$cache_key}\n"
if $dl_debug;
return $FullCache{$cache_key};
}
if ($is_insensitive_fs) {
# We have a case-insensitive filesystem...
my ($key) = grep { lc($_) eq lc($cache_key) } keys %FullCache;
if (defined $key) {
print STDERR " found case-insensitively in FullCache as $FullCache{$key}\n"
if $dl_debug;
return $FullCache{$key};
}
}
print STDERR " fall back to DynaLoader::dl_findfile\n" if $dl_debug;
return $dl_findfile->(@_);
}
# Find and extract .dll from PAR files for a given dynamic module.
sub _bootstrap {
my (@args) = @_;
my ($module) = $args[0] or return;
my @modparts = split(/::/, $module);
my $modfname = $modparts[-1];
$modfname = &DynaLoader::mod2fname(\@modparts)
if defined &DynaLoader::mod2fname;
if (($^O eq 'NetWare') && (length($modfname) > 8)) {
$modfname = substr($modfname, 0, 8);
}
my $modpname = join((($^O eq 'MacOS') ? ':' : '/'), @modparts);
my $file = $cache_key = "auto/$modpname/$modfname.$DynaLoader::dl_dlext";
if ($FullCache{$file}) {
# TODO: understand
local $DynaLoader::do_expand = 1;
return $bootstrap->(@args);
}
my $member;
# First, try to find things in the preferentially loaded PARs:
$member = PAR::_find_par_internals([@PAR::PAR_INC], undef, $file, 1)
if defined &PAR::_find_par_internals;
# If that failed to find the dll, let DynaLoader (try or) throw an error
unless ($member) {
my $filename = eval { $bootstrap->(@args) };
return $filename if not $@ and defined $filename;
# Now try the fallback pars
$member = PAR::_find_par_internals([@PAR::PAR_INC_LAST], undef, $file, 1)
if defined &PAR::_find_par_internals;
# If that fails, let dynaloader have another go JUST to throw an error
# While this may seem wasteful, nothing really matters once we fail to
# load shared libraries!
unless ($member) {
return $bootstrap->(@args);
}
}
$FullCache{$file} = _dl_extract($member);
# Now extract all associated shared objs in the same auto/ dir
# XXX: shouldn't this also set $FullCache{...} for those files?
my $first = $member->fileName;
my $path_pattern = $first;
$path_pattern =~ s{[^/]*$}{};
if ($PAR::LastAccessedPAR) {
foreach my $member ( $PAR::LastAccessedPAR->members ) {
next if $member->isDirectory;
my $name = $member->fileName;
next if $name eq $first;
next unless $name =~ m{^/?\Q$path_pattern\E\/[^/]*\.\Q$DynaLoader::dl_dlext\E[^/]*$};
$name =~ s{.*/}{};
_dl_extract($member, $name);
}
}
local $DynaLoader::do_expand = 1;
return $bootstrap->(@args);
}
sub _dl_extract {
my ($member, $name) = @_;
$name ||= $member->crc32String . ".$DynaLoader::dl_dlext";
my $filename = File::Spec->catfile($ENV{PAR_TEMP} || File::Spec->tmpdir, $name);
($filename) = $filename =~ /^([\x20-\xff]+)$/;
return $filename if -e $filename && -s _ == $member->uncompressedSize;
# $filename doesn't exist or hasn't been completely extracted:
# extract it under a temporary name that isn't likely to be used
# by concurrent processes doing the same
my $tempname = "$filename.$$";
$member->extractToFileNamed($tempname) == Archive::Zip::AZ_OK()
or die "Can't extract archive member ".$member->fileName." to $tempname: $!";
# now that we have a "good" copy in $tempname, rename it to $filename;
# if this fails (e.g. some OSes won't let you delete DLLs that are
# in use), but $filename exists, we assume that $filename is also
# "good": remove $tempname and return $filename
unless (rename($tempname, $filename))
{
-e $filename or die "can't rename $tempname to $filename: $!";
unlink($tempname);
}
return $filename;
}
1;
=head1 SEE ALSO
L<PAR>
=head1 AUTHORS
Audrey Tang E<lt>cpan@audreyt.orgE<gt>
You can write
to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty mail to
E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
Please submit bug reports to E<lt>bug-par@rt.cpan.orgE<gt>.
=head1 COPYRIGHT
Copyright 2002-2010 by Audrey Tang
E<lt>cpan@audreyt.orgE<gt>.
Copyright 2006-2010 by Steffen Mueller
E<lt>smueller@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F<LICENSE>.
=cut

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

File diff suppressed because it is too large Load Diff

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

410
database/perl/vendor/lib/PAR/Repository/Query.pm vendored Normal file
View File

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

92
database/perl/vendor/lib/PAR/SetupProgname.pm vendored Normal file
View File

@@ -0,0 +1,92 @@
package PAR::SetupProgname;
$PAR::SetupProgname::VERSION = '1.002';
use 5.006;
use strict;
use warnings;
use Config ();
=head1 NAME
PAR::SetupProgname - Setup $ENV{PAR_PROGNAME}
=head1 SYNOPSIS
PAR guts, beware. Check L<PAR>
=head1 DESCRIPTION
Routines to setup the C<PAR_PROGNAME> environment variable.
Read the C<PAR::Environment> manual.
The C<set_progname()> subroutine sets up the C<PAR_PROGNAME>
environment variable
=cut
# for PAR internal use only!
our $Progname = $ENV{PAR_PROGNAME} || $0;
# same code lives in PAR::Packer's par.pl!
sub set_progname {
require File::Spec;
if (defined $ENV{PAR_PROGNAME} and $ENV{PAR_PROGNAME} =~ /(.+)/) {
$Progname = $1;
}
$Progname = $0 if not defined $Progname;
if (( () = File::Spec->splitdir($Progname) ) > 1 or !$ENV{PAR_PROGNAME}) {
if (open my $fh, $Progname) {
return if -s $fh;
}
if (-s "$Progname$Config::Config{_exe}") {
$Progname .= $Config::Config{_exe};
return;
}
}
foreach my $dir (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}) {
next if exists $ENV{PAR_TEMP} and $dir eq $ENV{PAR_TEMP};
my $name = File::Spec->catfile($dir, "$Progname$Config::Config{_exe}");
if (-s $name) { $Progname = $name; last }
$name = File::Spec->catfile($dir, "$Progname");
if (-s $name) { $Progname = $name; last }
}
}
1;
__END__
=head1 SEE ALSO
L<PAR>, L<PAR::Environment>
=head1 AUTHORS
Audrey Tang E<lt>cpan@audreyt.orgE<gt>,
Steffen Mueller E<lt>smueller@cpan.orgE<gt>
You can write
to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty mail to
E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
Please submit bug reports to E<lt>bug-par@rt.cpan.orgE<gt>. If you need
support, however, joining the E<lt>par@perl.orgE<gt> mailing list is
preferred.
=head1 COPYRIGHT
Copyright 2002-2010 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
Copyright 2006-2010 by Steffen Mueller E<lt>smueller@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F<LICENSE>.
=cut

183
database/perl/vendor/lib/PAR/SetupTemp.pm vendored Normal file
View File

@@ -0,0 +1,183 @@
package PAR::SetupTemp;
$PAR::SetupTemp::VERSION = '1.002';
use 5.006;
use strict;
use warnings;
use Fcntl ':mode';
use PAR::SetupProgname;
=head1 NAME
PAR::SetupTemp - Setup $ENV{PAR_TEMP}
=head1 SYNOPSIS
PAR guts, beware. Check L<PAR>
=head1 DESCRIPTION
Routines to setup the C<PAR_TEMP> environment variable.
The documentation of how the temporary directories are handled
is currently scattered across the C<PAR> manual and the
C<PAR::Environment> manual.
The C<set_par_temp_env()> subroutine sets up the C<PAR_TEMP>
environment variable.
=cut
# for PAR internal use only!
our $PARTemp;
# name of the canary file
our $Canary = "_CANARY_.txt";
# how much to "date back" the canary file (in seconds)
our $CanaryDateBack = 24 * 3600; # 1 day
# The C version of this code appears in myldr/mktmpdir.c
# This code also lives in PAR::Packer's par.pl as _set_par_temp!
sub set_par_temp_env {
PAR::SetupProgname::set_progname()
unless defined $PAR::SetupProgname::Progname;
if (defined $ENV{PAR_TEMP} and $ENV{PAR_TEMP} =~ /(.+)/) {
$PARTemp = $1;
return;
}
my $stmpdir = _get_par_user_tempdir();
die "unable to create cache directory" unless $stmpdir;
require File::Spec;
if (!$ENV{PAR_CLEAN} and my $mtime = (stat($PAR::SetupProgname::Progname))[9]) {
require Digest::SHA;
my $ctx = Digest::SHA->new(1);
if ($ctx and open(my $fh, "<$PAR::SetupProgname::Progname")) {
binmode($fh);
$ctx->addfile($fh);
close($fh);
}
$stmpdir = File::Spec->catdir(
$stmpdir,
"cache-" . ( $ctx ? $ctx->hexdigest : $mtime )
);
}
else {
$ENV{PAR_CLEAN} = 1;
$stmpdir = File::Spec->catdir($stmpdir, "temp-$$");
}
$ENV{PAR_TEMP} = $stmpdir;
mkdir $stmpdir, 0700;
$PARTemp = $1 if defined $ENV{PAR_TEMP} and $ENV{PAR_TEMP} =~ /(.+)/;
}
# Find any digester
# Used in PAR::Repository::Client!
sub _get_digester {
my $ctx = eval { require Digest::SHA; Digest::SHA->new(1) }
|| eval { require Digest::SHA1; Digest::SHA1->new }
|| eval { require Digest::MD5; Digest::MD5->new };
return $ctx;
}
# find the per-user temporary directory (eg /tmp/par-$USER)
# Used in PAR::Repository::Client!
sub _get_par_user_tempdir {
my $username = _find_username();
my $temp_path;
foreach my $path (
(map $ENV{$_}, qw( PAR_TMPDIR TMPDIR TEMPDIR TEMP TMP )),
qw( C:\\TEMP /tmp . )
) {
next unless defined $path and -d $path and -w $path;
# create a temp directory that is unique per user
# NOTE: $username may be in an unspecified charset/encoding;
# use a name that hopefully works for all of them;
# also avoid problems with platform-specific meta characters in the name
$temp_path = File::Spec->catdir($path, "par-".unpack("H*", $username));
($temp_path) = $temp_path =~ /^(.*)$/s;
unless (mkdir($temp_path, 0700) || $!{EEXIST}) {
warn "creation of private subdirectory $temp_path failed (errno=$!)";
return;
}
unless ($^O eq 'MSWin32') {
my @st;
unless (@st = lstat($temp_path)) {
warn "stat of private subdirectory $temp_path failed (errno=$!)";
return;
}
if (!S_ISDIR($st[2])
|| $st[4] != $<
|| ($st[2] & 0777) != 0700 ) {
warn "private subdirectory $temp_path is unsafe (please remove it and retry your operation)";
return;
}
}
last;
}
return $temp_path;
}
# tries hard to find out the name of the current user
sub _find_username {
my $username;
my $pwuid;
# does not work everywhere:
eval {($pwuid) = getpwuid($>) if defined $>;};
if ( defined(&Win32::LoginName) ) {
$username = &Win32::LoginName;
}
elsif (defined $pwuid) {
$username = $pwuid;
}
else {
$username = $ENV{USERNAME} || $ENV{USER} || 'SYSTEM';
}
return $username;
}
1;
__END__
=head1 SEE ALSO
L<PAR>, L<PAR::Environment>
=head1 AUTHORS
Audrey Tang E<lt>cpan@audreyt.orgE<gt>,
Steffen Mueller E<lt>smueller@cpan.orgE<gt>
You can write
to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty mail to
E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
Please submit bug reports to E<lt>bug-par@rt.cpan.orgE<gt>. If you need
support, however, joining the E<lt>par@perl.orgE<gt> mailing list is
preferred.
=head1 COPYRIGHT
Copyright 2002-2010 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
Copyright 2006-2010 by Steffen Mueller E<lt>smueller@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F<LICENSE>.
=cut

1065
database/perl/vendor/lib/PAR/Tutorial.pod vendored Normal file
View File

File diff suppressed because it is too large Load Diff