Mineplex/.FILES USED TO GET TO WHERE WE ARE PRESENTLY/xampp/perl/vendor/lib/PAR/SetupTemp.pm

184 lines
4.6 KiB
Perl
Raw Normal View History

2023-05-17 21:44:01 +00:00
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