Initial Commit

database/perl/vendor/lib/PAR/SetupTemp.pm

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