File Coverage

blib/lib/PAR/SetupTemp.pm
Criterion Covered Total %
statement 53 63 84.1
branch 17 30 56.6
condition 12 32 37.5
subroutine 8 9 88.8
pod 0 1 0.0
total 90 135 66.6


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__