view release on metacpan or  search on metacpan

t/oddmuse-wiki.pl  view on Meta::CPAN

    if ($delete) {
      my $status = DeletePage($OpenPageName);
      print ' ', ($status ? T('not deleted:') . ' ' . $status : T('deleted'));
    } else {
      ExpireKeepFiles();
    }
  }
}

sub ExpireKeepFiles {   # call with opened page
  return unless $KeepDays;
  my $expirets = $Now - ($KeepDays * 86400); # 24*60*60
  foreach my $revision (GetKeepRevisions($OpenPageName)) {
    my $keep = GetKeptRevision($revision);
    next if $keep->{'keep-ts'} >= $expirets;
    next if $KeepMajor and $keep->{revision} == $Page{lastmajor};
    Unlink(GetKeepFile($OpenPageName, $revision));
  }
}

sub ReadFile {
  if (open(my $IN, '<:encoding(UTF-8)', encode_utf8(shift))) {
    local $/ = undef; # Read complete files
    my $data=<$IN>;
    close $IN;
    return (1, $data);
  }
  return (0, '');
}

sub ReadFileOrDie  {
  my ($file) = @_;
  my ($status, $data);
  ($status, $data) = ReadFile($file);
  if (not $status) {
    ReportError(Ts('Cannot open %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
  }
  return $data;
}

sub WriteStringToFile {
  my ($file, $string) = @_;
  open(my $OUT, '>:encoding(UTF-8)', encode_utf8($file))
    or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
  print $OUT  $string;
  close($OUT);
}

sub AppendStringToFile {
  my ($file, $string) = @_;
  open(my $OUT, '>>:encoding(UTF-8)', encode_utf8($file))
    or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
  print $OUT  $string;
  close($OUT);
}

sub IsFile    { return -f encode_utf8(shift); }
sub IsDir     { return -d encode_utf8(shift); }
sub ZeroSize  { return -z encode_utf8(shift); }
sub Unlink    { return unlink(map { encode_utf8($_) } @_); }
sub Modified  { return (stat(encode_utf8(shift)))[9]; }
sub Glob      { return map { decode_utf8($_) } bsd_glob(encode_utf8(shift)); }
sub ChangeMod { return chmod(shift, map { encode_utf8($_) } @_); }
sub Rename    { return rename(encode_utf8($_[0]), encode_utf8($_[1])); }
sub RemoveDir { return rmdir(encode_utf8(shift)); }
sub ChangeDir { return chdir(encode_utf8(shift)); }

sub CreateDir {
  my ($newdir) = @_;
  return if IsDir($newdir);
  mkdir(encode_utf8($newdir), 0775)
    or ReportError(Ts('Cannot create %s', $newdir) . ": $!", '500 INTERNAL SERVER ERROR');
}

sub GetLockedPageFile {
  my $id = shift;
  return "$PageDir/$id.lck";
}

sub RequestLockDir {
  my ($name, $tries, $wait, $error, $retried) = @_;
  $tries ||= 4;
  $wait ||= 2;
  CreateDir($TempDir);
  my $lock = $LockDir . $name;
  my $n = 0;
  # Cannot use CreateDir because we don't want to skip mkdir if the directory
  # already exists.
  while (mkdir(encode_utf8($lock), 0555) == 0) {
    if ($n++ >= $tries) {
      my $ts = Modified($lock);
      if ($Now - $ts > $LockExpiration and $LockExpires{$name} and not $retried) { # XXX should we remove this now?
	ReleaseLockDir($name); # try to expire lock (no checking)
	return 1 if RequestLockDir($name, undef, undef, undef, 1);
      }
      return 0 unless $error;
      ReportError(Ts('Could not get %s lock', $name) . ": $!. ",
		  '503 SERVICE UNAVAILABLE', undef,
		  Ts('The lock was created %s.', CalcTimeSince($Now - $ts))
		  . ($retried && ' ' . T('Maybe the user running this script is no longer allowed to remove the lock directory?'))
		  . ' ' . T('Sometimes locks are left behind if a job crashes.') . ' '
		  . ($Now - $ts < 600 ? T('After ten minutes, you could try to unlock the wiki.')
		     : ScriptLink('action=unlock', T('Unlock Wiki'), 'unlock')));
    }
    sleep($wait);
  }
  $Locks{$name} = 1;
  return 1;
}

sub HandleSignals {
  my ($signal) = @_; # TODO should we pass it to CleanLock?
  CleanLock($_) foreach keys %Locks;
  exit; # let's count it as graceful exit
}

sub CleanLock {
  my ($name) = @_;
  $LockCleaners{$name}->() if exists $LockCleaners{$name};
  ReleaseLockDir($name); # TODO should we log this?
}