root/trunk/dev-tools/update-loblaw-test.plx

#!/usr/bin/perl

# This script is designed to be run launched by svn's post hooks under the
# uid of the Mercurial repository.  It generally lives in ~svn/bin
# and called from the repository post hooks

# This program might be of interest to people who want to do some sort of
# operation on files after an SVN commit that requires some set of
# commands to be run on the repository's local system.  In other words, if
# you really wish that when an SVN commit happened, you could log into the
# server and run a bunch of commands against a local checkout of what was
# just committed, then this script is for you.

# The whole thing is a hack -- no question.  If there's a better way to do
# this job, I'd love to hear about it.

# The sub's "safe_read_from_pipe" and read_from_process are:
# ====================================================================
# Copyright (c) 2000-2004 CollabNet.  All rights reserved.
#
# This software is licensed as described in the file COPYING, which
# you should have received as part of this distribution.  The terms
# are also available at http://subversion.tigris.org/license-1.html.
# If newer versions of this license are posted there, you may use a
# newer version instead, at your option.
#
# This software consists of voluntary contributions made by many
# individuals.  For exact contribution history, see the revision
# history and logs, available at http://subversion.tigris.org/.
# ====================================================================
#
#
# The rest of the file is:
#
# Copyright (c) 2006, 2007 Software Freedom Law Center, Inc.
#
# This software gives you freedom; it is licensed to you under version 3
# of the GNU General Public License.
#
# This software is distributed WITHOUT ANY WARRANTY, without even the
# implied warranties of MERCHANTABILITY and FITNESS FOR A PARTICULAR
# PURPOSE.  See the GNU General Public License for further details.
#
# You should have received a copy of the GNU General Public License,
# version 3.  If not, see <http://www.gnu.org/licenses/>
#
# License: GPLv3-only


use strict;
use warnings;

my $SVN = "/usr/bin/svn";
my $SVNLOOK = "/usr/bin/svnlook";
my $HG = '/usr/bin/hg';

my $LOBLAW_TRUNK_CHECKOUT = "/home/hg/SVNCheckouts/loblaw-trunk";
my $LOBLAW_TEST_HG_CHECKOUT = "/home/hg/HGCheckouts/loblaw-test";

my $PIPE_FILE = "/home/svn/pipes/loblaw-update";

use POSIX ":sys_wait_h";
use Fcntl;             # for sysopen
use Carp;
use File::Temp qw/:POSIX tempfile mkstemps/;
use File::Path;
use File::Basename;
use File::Copy;
###############################################################################
use Unix::Syslog qw(:subs);
use Unix::Syslog qw(:macros);
use Carp;
{
#  my $PAGE_EMAIL = '6463617006@tmomail.net';
  my $PAGE_EMAIL = 'root@softwarefreedom.org';
  my %messageHistory;

  sub DoLog ($$$;$) {
    my($type, $user, $message, $cleanupCode) = @_;

    use Date::Manip;
    my $NOW = ParseDate("now");
    syslog LOG_INFO, $message;

    my $lastTime = $messageHistory{$message};

    my $sendIt = 0;
    if (not defined $lastTime) {
      $sendIt = 1;
    } else {
      my $err;
      my $sinceLast = DateCalc($lastTime,"+ 10 minutes",\$err);
      $sendIt = 1 if ($NOW gt $sinceLast);
    }
    if ($sendIt) {
      open(SENDMAIL, "|/usr/sbin/sendmail -f root\@softwarefreedom.org -t");
      print SENDMAIL "To: $PAGE_EMAIL,root\@softwarefreedom.org";
      print SENDMAIL ", $user\@softwarefreedom.org" if defined $user;
      print SENDMAIL "\nFrom: root\@softwarefreedom.org\n",
      "Subject: LOBLAW,COMMIT_HOOK\n\n$message\n.\n";
      close(SENDMAIL);
      if ($? != 0) {
        syslog LOG_INFO, "Unable to perform sendmail: $!";
      } else {
        $messageHistory{$message} = $NOW;
      }
    }
    my $more;
    $more = &$cleanupCode if defined $cleanupCode and ref $cleanupCode;
    $message .= "  $more" if (defined $more and $more !~ /^\s*$/);
    croak $message if $type eq "die";
    warn $message;
  }
  sub DieLog ($;$) {
    DoLog("die", undef, $_[0], $_[1]);
  }
  sub WarnLog ($$) {
    DoLog("warn", $_[0], $_[1]);
  }
}
###############################################################################

# Start a child process safely without using /bin/sh.
sub safe_read_from_pipe
{
  unless (@_)
    {
      DieLog("$0: safe_read_from_pipe passed no arguments.");
    }

  my $pid = open(SAFE_READ, '-|');
  unless (defined $pid)
    {
      DieLog("$0: cannot fork: $!");
    }
  unless ($pid)
    {
      open(STDERR, ">&STDOUT")
        or DieLog("$0: cannot dup STDOUT: $!");
      exec(@_)
        or DieLog("$0: cannot exec `@_': $!\n");
    }
  my @output;
  while (<SAFE_READ>)
    {
      s/[\r\n]+$//;
      push(@output, $_);
    }
  close(SAFE_READ);
  my $result = $?;
  my $exit   = $result >> 8;
  my $signal = $result & 127;
  my $cd     = $result & 128 ? "with core dump" : "";
  if ($signal or $cd)
    {
      DieLog("$0: pipe from `@_' failed $cd: exit=$exit signal=$signal\n");
    }
  if (wantarray)
    {
      return ($result, @output);
    }
  else
    {
      return $result;
    }
}
###############################################################################
# Use safe_read_from_pipe to start a child process safely and return
# the output if it succeeded or an error message followed by the output
# if it failed.
sub read_from_process
{
  unless (@_)
    {
      DieLog("$0: read_from_process passed no arguments.");
    }
  my ($status, @output) = &safe_read_from_pipe(@_);
  if ($status)
    {
      return ("$0: `@_' failed with this output:", @output);
    }
  else
    {
      return @output;
    }
}
###############################################################################
my $LOCK_FILE = "/home/hg/locks/update-loblaw-test-unpackaged-lock";

my $LOCK_CLEANUP_CODE = sub {
  return (unlink($LOCK_FILE) != 1) ?
    "Failed unlink of $LOCK_FILE.  Could cause trouble." :
    "";
};

###############################################################################
###############################################################################
###############################################################################
sub DoUpdate ($) {
  my ($revision) = @_;

  chdir $LOBLAW_TRUNK_CHECKOUT or
    DieLog("unable to change directory to $LOBLAW_TRUNK_CHECKOUT: $!",
           $LOCK_CLEANUP_CODE);

  my @cleanupLines = read_from_process($SVN, 'cleanup');
  my @updateLines = read_from_process($SVN, 'update');
  foreach my $line (@updateLines) {
    DieLog("conflict found on calendar update: $line", $LOCK_CLEANUP_CODE)
      if ($line =~ /^\s*C\s+/);
  }
  DieLog("update failure; missing revision line or " .
         "invalid revision number $1 (expect $revision or more) at end of: " . 
         join("\n", @updateLines), $LOCK_CLEANUP_CODE)
    unless ($updateLines[$#updateLines] =~ 
            /^\s*(?:Updated\s+to|At)\s+revision\s+(\d+)[\s\.]*$/i
            and $1 >= $revision);
}
###############################################################################

# Keep track of which revisions we've finished with.
my %CAUGHT_REVISIONS;
my %DUAL_REVISIONED_FILE_LIST;
my $LOBLAW_LIST_FILE = 'dev-tools/loblaw-unpackaged-files.dat';
###############################################################################
sub BuildDualVersionFileList () {
  %DUAL_REVISIONED_FILE_LIST = ();

  open(FILE_LIST, "<$LOBLAW_LIST_FILE")
    or DieLog("unable to open $LOBLAW_LIST_FILE: $!");
  while (my $line = <FILE_LIST>) {
    next if $line =~ /^\s*#/ or $line =~ /^\s*$/;
    unless ($line =~
            m%^\s*([/a-zA-Z0-9\-\.\_]+)\s+\=\>\s+/([/a-zA-Z0-9\-\.\_]+)\s*$%) {
      # I am extremely picky in this regex to be super-security concious
      DieLog("Invalid line in $LOBLAW_LIST_FILE: $line");
    }
    my($source, $destination) = ($1, $2);
    $DUAL_REVISIONED_FILE_LIST{$source} = $destination;
  }
  close FILE_LIST;
}
###############################################################################
sub ProcessRevision ($$) {
  my($repository, $revision) = @_;

  return unless $repository =~ m|Repository/loblaw\s*$|;

  chdir $LOBLAW_TRUNK_CHECKOUT or
    DieLog("unable to change directory to $LOBLAW_TRUNK_CHECKOUT: $!");

  my @svnLookChangedLines =
    read_from_process($SVNLOOK, 'changed', $repository, '-r', $revision);

  my @operateOnFiles;

  my $updateFileList = 0;
  $updateFileList = 1 if (keys %DUAL_REVISIONED_FILE_LIST <= 0);

  foreach my $changeLine (@svnLookChangedLines) {
    chomp $changeLine;
    # This script only keeps loblaw-test in sync with trunks' scripts and configs

    my(%vals);
    $vals{changeLine} = $changeLine;
    if ($changeLine
        =~ m|^\s*(\S)\s+trunk/$LOBLAW_LIST_FILE\s*$|) {
      $updateFileList = 1;
      next;
    } elsif ($changeLine =~ m%^\s*(\S)\s+trunk/((scripts|configs)/\S+)\s*$%) {
      ($vals{operation}, $vals{file}) = ($1, $2);
    }
    push(@operateOnFiles, \%vals)
      if (defined $vals{operation} and $vals{operation} !~ /^\s*I\s*/);
       # skip those cases where we didn't want to do anything with the file
       # and those that we *would* do something but were ignored items
  }
  my(@lockData) = read_from_process("/usr/bin/lockfile -r 8 $LOCK_FILE");

  DieLog("Failure to aquire lock in $repository for $revision. " .
         "loblaw-test Mercurial update aborted!")
    if defined $lockData[0] and $lockData[0] =~ /failed/;

  DoUpdate($revision);  # Make sure we have the latest and the greatest

  BuildDualVersionFileList() if $updateFileList;

  # HG process will read this var.
  $ENV{EMAIL} = 'svn@softwarefreedom.org';
  my $commitDone = 0;

  foreach my $vals (@operateOnFiles) {
    my($operation, $inputFile, $changeLine) =
      ($vals->{operation}, $vals->{file}, $vals->{changeLine});

    # if we already, through some stretch, we've done this version already,
    #   then just skip this one.
    next if defined $CAUGHT_REVISIONS{"$repository,$revision"};

    # See if this is a file we are actually processing over to the hg repository
    next unless defined $DUAL_REVISIONED_FILE_LIST{$inputFile};
    my $outputFile = $DUAL_REVISIONED_FILE_LIST{$inputFile};

    chdir $LOBLAW_TEST_HG_CHECKOUT or
      DieLog("unable to change directory to $LOBLAW_TEST_HG_CHECKOUT: $!");

    read_from_process($HG, 'update');
    read_from_process($HG, 'merge');
    read_from_process($HG, 'update');

    chdir $LOBLAW_TRUNK_CHECKOUT or
      DieLog("unable to change directory to $LOBLAW_TRUNK_CHECKOUT: $!");

    if ($operation =~ /^\s*(?:U|M|\~|L|A)\s*/) {
      my($dir, $filename);
      if (-d "$LOBLAW_TRUNK_CHECKOUT/$inputFile") {
        ($dir, $filename) = ($outputFile, "");
      } else {
        ($dir, $filename) = fileparse($outputFile);
      }
      eval { mkpath("$LOBLAW_TEST_HG_CHECKOUT/$dir", 0, 0755) };
      DieLog("Couldn't create $LOBLAW_TEST_HG_CHECKOUT/$dir: $@",
             $LOCK_CLEANUP_CODE) if ($@);

      # copy the actual file over, if it is a file and not a directory.
      unless ($filename =~ /^\s*$/) {
        copy($inputFile, "$LOBLAW_TEST_HG_CHECKOUT/$outputFile")
          or DieLog("Couldn't copy $inputFile into " .
                    "$LOBLAW_TEST_HG_CHECKOUT/$outputFile: $!",
             $LOCK_CLEANUP_CODE);
      }
      chdir $LOBLAW_TEST_HG_CHECKOUT or
        DieLog("unable to change directory to $LOBLAW_TEST_HG_CHECKOUT: $!");
      read_from_process($HG, 'add', "$outputFile")
        if ($operation =~ /^\s*A\s*/);
    } elsif ($operation =~ /^\s*D\s*/) {
      unlink("$LOBLAW_TEST_HG_CHECKOUT/$outputFile");
      chdir $LOBLAW_TEST_HG_CHECKOUT or
        DieLog("unable to change directory to $LOBLAW_TEST_HG_CHECKOUT: $!");
      read_from_process($HG, 'remove', "$outputFile");
    } else {
      DieLog("Invalid svnlook status, $operation, in $changeLine",
             $LOCK_CLEANUP_CODE);
    }
    chdir $LOBLAW_TRUNK_CHECKOUT or
      DieLog("unable to change directory to $LOBLAW_TRUNK_CHECKOUT: $!");
    my @svnLog = read_from_process($SVN, '-r', $revision, 'log', $inputFile);
    my($tempFH, $tempFile) = mkstemps( "/tmp/hgcommitXXXXXX", ".log");
    print $tempFH "From SVN Revision $revision:\n";
    foreach my $line (@svnLog) {
      chomp $line;
      next if $line =~ /^\s*\-+\s*$/;
      $line =~ s/^(.*\|.*\|.*)(\|.*)$/$1/;
      print $tempFH "$line\n";
    }
    $tempFH->close();
    chdir $LOBLAW_TEST_HG_CHECKOUT or
      DieLog("unable to change directory to $LOBLAW_TEST_HG_CHECKOUT: $!");
    my @vals = read_from_process($HG, 'commit', '-l', $tempFile,
                                 "$outputFile");
    unlink($tempFile);
    DieLog("Unexpected output from commit: " . join("\n", @vals),
           $LOCK_CLEANUP_CODE) if (@vals > 0);
    $commitDone = 1;
  }
  chdir $LOBLAW_TEST_HG_CHECKOUT or
      DieLog("unable to change directory to $LOBLAW_TEST_HG_CHECKOUT: $!");
  read_from_process($HG, 'push', '-f') if $commitDone;
  &$LOCK_CLEANUP_CODE;
}
###############################################################################
sub MakePipe ($) {
  my($file) = @_;

  unless (-p $file) {   # not a pipe
    POSIX::mkfifo($file, 0660) or die "can't mknod $file: $!";
  }
}
###############################################################################
my %FORK_STATUS;


sub REAPER {
  my $child;
  # If a second child dies while in the signal handler caused by the
  # first death, we won't get another signal. So must loop here else
  # we will leave the unreaped child as a zombie. And the next time
  # two children die we get another zombie. And so on.
  while (($child = waitpid(-1,WNOHANG)) > 0) {
    $FORK_STATUS{$child}{exitCode} = $?;
    $FORK_STATUS{$child}{exitString} = $!;
  }
  $SIG{CHLD} = \&REAPER;
}

# Don't fear the reaper....

$SIG{CHLD} = \&REAPER;

###############################################################################
sub Execute {
  my %caughtRevisions;

  umask 0007;
  $| = 1;

  while (1) {
    foreach my $child (keys %FORK_STATUS) {
      if (defined $FORK_STATUS{$child}{exitCode}) {
        if ($FORK_STATUS{$child}{exitCode} == 0) {
          my $key = "$FORK_STATUS{$child}{repository}," .
                    $FORK_STATUS{$child}{revision};
          $CAUGHT_REVISIONS{$key} = time();
        } else {
          DieLog("Non-zero exit status ($FORK_STATUS{$child}{exitCode}) " .
                "for $FORK_STATUS{$child}{repository} processing of " .
                "$FORK_STATUS{$child}{revision}: " .
                $FORK_STATUS{$child}{exitString})
        }
        delete $FORK_STATUS{$child};
      }
    }
    MakePipe($PIPE_FILE) unless -p $PIPE_FILE;
    unless (-p $PIPE_FILE) {
      DieLog("$PIPE_FILE just won't be a pipe."); sleep 60; next;
    }

    my $ii;
    for ($ii = 0, select(undef, undef, undef, 0.2);
         $ii < 25 and not open(FIFO, "<$PIPE_FILE"); $ii++) {
      select(undef, undef, undef, 0.3); # sleep fraction of second
    }
    if ($ii >= 25) {
      DieLog("Unable to read pipe in $PIPE_FILE after 25 tries," .
              "sleeping 4 seconds and trying again: $!");
      sleep 4; next;
    }

    my(@lines) = <FIFO>;
    close FIFO;
    foreach my $line (@lines) {
      unless ($line =~ /^\s*REPOSITORY:\s*\"([^"]+)\"\s+
                      REVISION:\s+(\d+)\s*$/x) {
        DieLog("Invalid line from pipe: $line"); next;
      }
      my($repository, $revision) = ($1, $2);
      my $childPid;
      if (not defined($childPid = fork())) {
        DieLog("fork failed when processing $repository with "
                . "revision $revision: $!");
        sleep 60;
        next;
      } elsif ($childPid) {
        # The parent just goes on...
        $FORK_STATUS{$childPid}{repository} = $repository;
        $FORK_STATUS{$childPid}{revision} = $revision;
        next;
      } else {
        # The child does the revision process.
        delete $SIG{CHLD};
        $0 = "$0 handles $revision in $repository";
        ProcessRevision($repository, $revision);
        exit 0;
      }
    }
    # give a chance for the FIFO to recover
    #    DieLog("Error encountered closing $PIPE_FILE: $!") unless ($? == n0);
  }
}
###############################################################################

open(PID, ">/home/hg/pids/loblaw-test-update.pid") or 
  DieLog("Unable to open PID file: $!");
print PID "$$\n";
close(PID);
DieLog("Unable to close PID file: $!") unless ($? == 0);
Execute();

__END__
# Local variables:
# compile-command: "perl -c update-loblaw-test.plx"
# End: