line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PAR::SetupTemp; |
2
|
|
|
|
|
|
|
$PAR::SetupTemp::VERSION = '1.002'; |
3
|
|
|
|
|
|
|
|
4
|
4
|
|
|
4
|
|
132
|
use 5.006; |
|
4
|
|
|
|
|
34
|
|
5
|
4
|
|
|
4
|
|
27
|
use strict; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
107
|
|
6
|
4
|
|
|
4
|
|
20
|
use warnings; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
173
|
|
7
|
|
|
|
|
|
|
|
8
|
4
|
|
|
4
|
|
25
|
use Fcntl ':mode'; |
|
4
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
1769
|
|
9
|
|
|
|
|
|
|
|
10
|
4
|
|
|
4
|
|
31
|
use PAR::SetupProgname; |
|
4
|
|
|
|
|
24
|
|
|
4
|
|
|
|
|
3953
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
PAR::SetupTemp - Setup $ENV{PAR_TEMP} |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 SYNOPSIS |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
PAR guts, beware. Check L |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=head1 DESCRIPTION |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
Routines to setup the C environment variable. |
23
|
|
|
|
|
|
|
The documentation of how the temporary directories are handled |
24
|
|
|
|
|
|
|
is currently scattered across the C manual and the |
25
|
|
|
|
|
|
|
C manual. |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
The C subroutine sets up the C |
28
|
|
|
|
|
|
|
environment variable. |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=cut |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# for PAR internal use only! |
33
|
|
|
|
|
|
|
our $PARTemp; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# name of the canary file |
36
|
|
|
|
|
|
|
our $Canary = "_CANARY_.txt"; |
37
|
|
|
|
|
|
|
# how much to "date back" the canary file (in seconds) |
38
|
|
|
|
|
|
|
our $CanaryDateBack = 24 * 3600; # 1 day |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# The C version of this code appears in myldr/mktmpdir.c |
41
|
|
|
|
|
|
|
# This code also lives in PAR::Packer's par.pl as _set_par_temp! |
42
|
|
|
|
|
|
|
sub set_par_temp_env { |
43
|
7
|
50
|
|
7
|
0
|
26
|
PAR::SetupProgname::set_progname() |
44
|
|
|
|
|
|
|
unless defined $PAR::SetupProgname::Progname; |
45
|
|
|
|
|
|
|
|
46
|
7
|
100
|
66
|
|
|
47
|
if (defined $ENV{PAR_TEMP} and $ENV{PAR_TEMP} =~ /(.+)/) { |
47
|
3
|
|
|
|
|
10
|
$PARTemp = $1; |
48
|
3
|
|
|
|
|
7
|
return; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
4
|
|
|
|
|
19
|
my $stmpdir = _get_par_user_tempdir(); |
52
|
4
|
50
|
|
|
|
17
|
die "unable to create cache directory" unless $stmpdir; |
53
|
|
|
|
|
|
|
|
54
|
4
|
|
|
|
|
29
|
require File::Spec; |
55
|
4
|
100
|
66
|
|
|
56
|
if (!$ENV{PAR_CLEAN} and my $mtime = (stat($PAR::SetupProgname::Progname))[9]) { |
56
|
2
|
|
|
|
|
1152
|
require Digest::SHA; |
57
|
2
|
|
|
|
|
5303
|
my $ctx = Digest::SHA->new(1); |
58
|
|
|
|
|
|
|
|
59
|
2
|
50
|
33
|
|
|
138
|
if ($ctx and open(my $fh, "<$PAR::SetupProgname::Progname")) { |
60
|
2
|
|
|
|
|
11
|
binmode($fh); |
61
|
2
|
|
|
|
|
11
|
$ctx->addfile($fh); |
62
|
2
|
|
|
|
|
144
|
close($fh); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
2
|
50
|
|
|
|
62
|
$stmpdir = File::Spec->catdir( |
66
|
|
|
|
|
|
|
$stmpdir, |
67
|
|
|
|
|
|
|
"cache-" . ( $ctx ? $ctx->hexdigest : $mtime ) |
68
|
|
|
|
|
|
|
); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
else { |
71
|
2
|
|
|
|
|
25
|
$ENV{PAR_CLEAN} = 1; |
72
|
2
|
|
|
|
|
25
|
$stmpdir = File::Spec->catdir($stmpdir, "temp-$$"); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
4
|
|
|
|
|
44
|
$ENV{PAR_TEMP} = $stmpdir; |
76
|
4
|
|
|
|
|
280
|
mkdir $stmpdir, 0700; |
77
|
|
|
|
|
|
|
|
78
|
4
|
50
|
33
|
|
|
87
|
$PARTemp = $1 if defined $ENV{PAR_TEMP} and $ENV{PAR_TEMP} =~ /(.+)/; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# Find any digester |
82
|
|
|
|
|
|
|
# Used in PAR::Repository::Client! |
83
|
|
|
|
|
|
|
sub _get_digester { |
84
|
|
|
|
|
|
|
my $ctx = eval { require Digest::SHA; Digest::SHA->new(1) } |
85
|
|
|
|
|
|
|
|| eval { require Digest::SHA1; Digest::SHA1->new } |
86
|
0
|
|
0
|
0
|
|
0
|
|| eval { require Digest::MD5; Digest::MD5->new }; |
87
|
0
|
|
|
|
|
0
|
return $ctx; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# find the per-user temporary directory (eg /tmp/par-$USER) |
91
|
|
|
|
|
|
|
# Used in PAR::Repository::Client! |
92
|
|
|
|
|
|
|
sub _get_par_user_tempdir { |
93
|
4
|
|
|
4
|
|
15
|
my $username = _find_username(); |
94
|
4
|
|
|
|
|
11
|
my $temp_path; |
95
|
4
|
|
|
|
|
58
|
foreach my $path ( |
96
|
|
|
|
|
|
|
(map $ENV{$_}, qw( PAR_TMPDIR TMPDIR TEMPDIR TEMP TMP )), |
97
|
|
|
|
|
|
|
qw( C:\\TEMP /tmp . ) |
98
|
|
|
|
|
|
|
) { |
99
|
4
|
50
|
33
|
|
|
151
|
next unless defined $path and -d $path and -w $path; |
|
|
|
33
|
|
|
|
|
100
|
|
|
|
|
|
|
# create a temp directory that is unique per user |
101
|
|
|
|
|
|
|
# NOTE: $username may be in an unspecified charset/encoding; |
102
|
|
|
|
|
|
|
# use a name that hopefully works for all of them; |
103
|
|
|
|
|
|
|
# also avoid problems with platform-specific meta characters in the name |
104
|
4
|
|
|
|
|
103
|
$temp_path = File::Spec->catdir($path, "par-".unpack("H*", $username)); |
105
|
4
|
|
|
|
|
38
|
($temp_path) = $temp_path =~ /^(.*)$/s; |
106
|
4
|
50
|
66
|
|
|
399
|
unless (mkdir($temp_path, 0700) || $!{EEXIST}) { |
107
|
0
|
|
|
|
|
0
|
warn "creation of private subdirectory $temp_path failed (errno=$!)"; |
108
|
0
|
|
|
|
|
0
|
return; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
4
|
50
|
|
|
|
69
|
unless ($^O eq 'MSWin32') { |
112
|
4
|
|
|
|
|
10
|
my @st; |
113
|
4
|
50
|
|
|
|
80
|
unless (@st = lstat($temp_path)) { |
114
|
0
|
|
|
|
|
0
|
warn "stat of private subdirectory $temp_path failed (errno=$!)"; |
115
|
0
|
|
|
|
|
0
|
return; |
116
|
|
|
|
|
|
|
} |
117
|
4
|
50
|
33
|
|
|
111
|
if (!S_ISDIR($st[2]) |
|
|
|
33
|
|
|
|
|
118
|
|
|
|
|
|
|
|| $st[4] != $< |
119
|
|
|
|
|
|
|
|| ($st[2] & 0777) != 0700 ) { |
120
|
0
|
|
|
|
|
0
|
warn "private subdirectory $temp_path is unsafe (please remove it and retry your operation)"; |
121
|
0
|
|
|
|
|
0
|
return; |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
4
|
|
|
|
|
12
|
last; |
126
|
|
|
|
|
|
|
} |
127
|
4
|
|
|
|
|
28
|
return $temp_path; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# tries hard to find out the name of the current user |
131
|
|
|
|
|
|
|
sub _find_username { |
132
|
4
|
|
|
4
|
|
13
|
my $username; |
133
|
|
|
|
|
|
|
my $pwuid; |
134
|
|
|
|
|
|
|
# does not work everywhere: |
135
|
4
|
50
|
|
|
|
9
|
eval {($pwuid) = getpwuid($>) if defined $>;}; |
|
4
|
|
|
|
|
3249
|
|
136
|
|
|
|
|
|
|
|
137
|
4
|
50
|
|
|
|
53
|
if ( defined(&Win32::LoginName) ) { |
|
|
50
|
|
|
|
|
|
138
|
0
|
|
|
|
|
0
|
$username = &Win32::LoginName; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
elsif (defined $pwuid) { |
141
|
4
|
|
|
|
|
14
|
$username = $pwuid; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
else { |
144
|
0
|
|
0
|
|
|
0
|
$username = $ENV{USERNAME} || $ENV{USER} || 'SYSTEM'; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
4
|
|
|
|
|
14
|
return $username; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
1; |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
__END__ |