#!/usr/bin/perl

##################################################################################
# This code is Copyright 2010 Tony Lewis <tlewis@exelana.com>.
#
#   This program is free software: you can redistribute it and/or modify it
#   under the terms of the GNU General Public License as published by the Free
#   Software Foundation, either version 3 of the License, or (at your option)
#   any later version.
#
#   This program is distributed in the hope that it will be useful, but WITHOUT
#   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
#   FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
#   more details.
#
#   You should have received a copy of the GNU General Public License along with
#   this program.  If not, see http://www.gnu.org/licenses/.
##################################################################################

# Version 2.1
#
# Version 2.1 added --examine option
# Version 2.0 converted to Perl script that works on DOCX files.
# Version 1 was a Windows executable that worked on RTF files.
#
# Time-stamp: 2010-09-03 14:06:56

# If your computer has everything you need installed (Perl, zip, and unzip)
# then you can just enter the following command to get started: perl oneauth
#
# You will see the following message: (ignore the Perl wrapper)
my $helpMessage = <<EndOfHelp;
Change all revision authors in a DOCX document to the same author.

oneauth inpath [outpath] [--author name] [--examine] [--select] [--who]

  inpath         The drive, path and file name of the input DOCX file.
  outpath        The drive, path and file name of the output DOCX file.
  --author name  The name to appear as the author of the revisions.
  --examine      Display the details about changes made by an author.
  --select       Allow user to select authors to be replaced.
  --who          Lists the authors for the input DOCX file.

Note: outpath is required unless --examine or --who is specified.

Examples:
oneauth in.docx out.docx --author "Big Company"
oneauth in.docx out.docx --select --author "Big Company"
oneauth in.docx --who
oneauth in.docx --examine
oneauth in.docx --examine --author "John Doe"
EndOfHelp
#
# ----------------------------------------------------------------------------
# This is a Perl script so you will need a Perl interpreter on your computer.
# If you want to run this on Windows, you can download an interpreter from
# http://strawberryperl.com
#
# After you install Perl, open a new command prompt and try this command:
# perl oneauth
#
# ----------------------------------------------------------------------------
# The script depends on having zip and unzip commands that can handle ZIP
# archives. The first thing the script does is check that your OS has
# everything you need. If it complains about not finding the zip/unzip
# utilities, you can download them from:
# ftp://ftp.info-zip.org/pub/infozip/
#
# Choose the folder that corresponds to your OS (probably 'win32') and
# download the latest unz###xn.exe and the latest zip###xn.zip to your
# favorite download folder. When I last checked the versions were
# unz600xn.exe and zip300xn.zip
#
# Then you will need to run unz###xn.exe in some folder in your path followed
# by running unzip over zip###xn.zip. I chose to put them into
# C:\strawberry\c\bin to live alongside the Strawberry Perl files. If you
# have some utility directory, that will work just as well.
#
# For example:
# cd \strawberry\c\bin
# \download\unz600xn.exe
# unzip \download\zip300xn.zip

my $os = ($^O =~ /mswin32/i) ? "windows" : ($^O =~ /darwin/i) ? "macosx" : "unix";
checkCmd("zip", "unzip");

if (scalar(@ARGV) == 0)
{
  doHelp();
  exit;
}

my $debug = 0;
my $examine = 0;
my $author = "";
my $inpath = "";
my $outpath = "";
my $select = "";
my $who = 0;

while (@ARGV)
{
  if ($ARGV[0] eq "--author")
  {
    shift @ARGV;
    $author = shift @ARGV;
  } elsif ($ARGV[0] eq "--debug") {
    $debug = 1;
    shift @ARGV;
  } elsif ($ARGV[0] eq "--examine") {
    $examine = 1;
    shift @ARGV;
  } elsif ($ARGV[0] eq "--select") {
    $select = 1;
    shift @ARGV;
  } elsif ($ARGV[0] eq "--who") {
    $who = 1;
    shift @ARGV;
  } elsif ($ARGV[0] eq "--help") {
    doHelp();
    exit;
  } elsif ($inpath eq "" && substr($ARGV[0],0,2) ne "--") {
    $inpath = shift @ARGV;
  } elsif ($outpath eq "" && substr($ARGV[0],0,2) ne "--") {
    $outpath = shift @ARGV;
  } else {
    print "Cannot understand: $ARGV[0]\n";
    exit;
  }
}

die "You must specify an input file.\n" if $inpath eq "";
die "The input file must be in DOCX or DOCM format.\n" if $inpath !~ m/\.do(?:c|t)(?:x|m)$/i;
die "No such file: $inpath.\n" unless -f $inpath;
die "You must specify an output file.\n" if $outpath eq "" && !$who && !$examine;
die "You must specify an author.\n" if $author eq "" && !$who && !$examine;

$select = 1 if $examine && $author eq "";

# The regular expressions used to find revisions look for a number of different tags.
#
# Microsoft has documented the tags at http://msdn.microsoft.com/en-us/library/ff629396.aspx
#
# cell*        cellDel, cellIns, cellMerge
# customXml*   customXmlDelRangeEnd, customXmlDelRangeStart, customXmlInsRangeEnd,
#              customXmlInsRangeStart,
# del*         del, delInstrText, delText
# ins          ins
# moveFrom*    moveFrom, moveFromRangeEnd,moveFromRangeStart,
# moveTo*      moveTo moveToRangeEnd,moveToRangeStart
# *Change      numberingChange, pPrChange, rPrChange, sectPrChange, tblGridChange,
#              tblPrChange, tblPrExChange, tcPrChange, trPrChange,

my $re = "cell\\w+|customXml\\w+|del\\w*|ins|move(?:From|To)\\w*|\\w+Change";

sysCopy($inpath,$outpath) unless $who || $examine;
die "Cannot create $outpath.\n" unless $who || $examine || -f $outpath;

my $target = $who || $examine ? $inpath : $outpath;
my $dir = $target;
$dir =~ s/\.do\w\w$//;
sysRemoveDir($dir) if -d $dir;
mkdir $dir;

sysCD($dir);
sysUnzip("-q", "../$target");

my $file = "word/document.xml";
open F, $file or die "Cannot open $file: $!";
binmode F;
read F, $contents, -s $file;
close F;
print "Read ",length($contents)," bytes.\n" if $debug;

my @selected = ();
if ($select || $who)
{
  my @authors = $contents =~ /<w:(?:$re) [^>]*author="([^"]*)[^>]*/g;
  my $last = "";
  my $count = 0;
  my @selection;
  print scalar(@authors)," revisions:\n";
  foreach my $author (sort {$a cmp $b} @authors)
  {
    $count++;
    if ($author ne "" && $author ne $last)
    {
      push @selection, $last if $select && $last ne "";
      print "  ", ($select ? scalar(@selection) . ". " : ""), "$last ($count revisions)\n" if $last ne "";
      $count = 0;
	  }
    $last = $author;
  }
  push @selection, $last if $select;
  print "  ", ($select ? scalar(@selection) . ". " : ""), "$last ($count revisions)\n" if $last ne "";

  my $done = !$select;
  while (!$done)
  {
    $done = 1;
    @selected = ();
    print "\nEnter the numbers to select (such as 1,3-7 or all): ";
    $resp = <STDIN>;
    chomp $resp;
    $resp =~ s/ //g;
    if ($resp eq "")
    {
      exit;
    } elsif ($resp =~ m/^all$/) {
      $select = 0;
    } else {
      my @parts = split(/,/, $resp);
      foreach my $part (@parts)
      {
        if ($part =~ m/^\d+$/)
        {
          if (0+$part >= 1 && $part-1 < scalar(@selection))
          {
            push @selected, $selection[$part-1];
          } else {
            print "The value $part is out of range.\n";
            $done = 0;
          }
        } elsif ($part =~ m/^(\d+)\-(\d+)$/) {
          my ($low, $high) = (0+$1, 0+$2);
          if ($low >= 1 && $low-1 < scalar(@selection) && $high >= 1 && $high-1 < scalar(@selection) && $low < $high)
					{
					  map { push @selected, $selection[$_-1] } $low..$high;
          } else {
            print "The range $part is invalid.\n";
            $done = 0;
				  }
        } else {
          print "I don't understand: \"$part\"\n";
          $done = 0;
        }
      }
	  }
  }

  if ($debug)
  {
    print "\nEntries specifying an author:\n\n";
    my @types = $contents =~ /<w:(\w+) [^>]*author="[^"]*[^>]*/g;
    $last = "";
    $count = 0;
    foreach my $type (sort {$a cmp $b} @types)
    {
      $count++;
      $found = $last =~ m/$re/;
      if ($type ne "" && $type ne $last)
      {
        print "", ($found ? "" : "* "), "$last [$count]",($found ? "" : " <-not found by regex"),
          "\n" if $last ne "";
        $count = 0;
			}
      $last = $type;
    }
    print "", ($found ? "" : "* "), "$last [$count]",($found ? "" : " <-not found by regex"),
      "\n" if $last ne "";
    print scalar(@types)," entries of all types.\n";
  }
}

if ($examine)
{
  push @selected, $author if $author ne "";
  my @elements = $contents =~ m/(<[^>]*>)([^<]*)/g;
  foreach my $selected (@selected)
  {
    print "Revisions made by $selected:\n";
    for (my $n = 0; $n < scalar(@elements); $n++)
    {
      my $element = $elements[$n];
      next if $element =~ m/^\s*$/;

      if ($element =~ m/<w:(?:$re) [^>]*author="$selected"[^>]*>/)
      {
        my ($when) = $element =~ m/w:date="([^"]*)"/;
        $when = "????-??-??T??:??:??Z" unless $when;
        $when =~ s/T/ /;
        $when =~ s/Z$//;
        if ($element =~ m/\/>$/)
        {
          my $pElement = $elements[$n-2];
          $pElement =~ s/^<w:(.*)>$/$1/;
          print "  $when: $pElement\n";
        } else {
          # print "  $element\n";
          my ($tag) = $element =~ m/<w:($re) /;
          my $m = $n + 1;
          my $action = "";
          my $text = "";
          my $textNext = 0;
          my $isField = 0;
          my $sawField = 0;
          while ($elements[$m] !~ m/<\/w:$tag>/)
				  {
            if ($textNext)
            {
              $text .= $elements[$m];
              $textNext = 0;
            } elsif ($elements[$m] =~ m/<w:(t|delText|instrText)\W/) {
              $textNext = 1;
              if ($1 eq "instrText")
              {
                $text .= "{" unless $isField;
                $isField = 1;
              } else {
                $text .= "}" if $isField;
                $isField = 0;
              }
            } elsif ($elements[$m] eq "<w:noBreakHyphen/>") {
              $text .= "-";
            } elsif ($elements[$m] =~ m/<w:rStyle w:val="([^"]*)"\/>/ ) {
              $action = "style $1";
            }
            $sawField = 1 if $elements[$m] =~ m/<w:fldChar /;
            $m++;
            die "Went past the end of the file searching for </w:$tag>\n" if $m >= scalar(@elements);
          }
          $text .= "}" if $isField;
          if ($text eq "" && $action ne "")
          {
            print "  $when: $action\n";
          } elsif ($text ne "") {
            print "  $when: $tag \"$text\"\n";
          } elsif ($debug && $sawField == 0 && $tag !~ m/PrChange$/) {
            print "  $when: $tag ???\n";
            my $m = $n + 1;
            while ($elements[$m] !~ m/<\/w:$tag>/)
	  			  {
              print "@@@ $elements[$m]\n" unless $elements[$m] =~ m/^\s*$/;
              $m++;
            }
            print "Continue? ";
            my $resp = <STDIN>;
            chomp $resp;
            exit unless $resp eq "y";
          }
        }
      }
    }
    print "\n";
  }
} elsif (!$who) {
  my $count = 0;
  if ($select)
  {
    map { $count += $contents =~ s/(<w:(?:$re) [^>]*author=")($_)("[^>]*>)/$1$author$3/g; }
		  @selected;
  } else {
    $count = $contents =~ s/(<w:(?:$re*) [^>]*author=")([^"]*)([^>]*>)/$1$author$3/g;
	}
  print "Changed $count revision author entries to \"$author\"\n";
  open F, ">$file" or die "Cannot write $file: $!";
  binmode F;
  print F $contents;
  close F;
  sysZip("-f -q","../$target","$file");
}
print "Result is ",length($contents)," bytes.\n" if $debug;
sysCD("..");
if ($debug)
{
  doSystem("xattr -d -r com.apple.quarantine $dir") if $os eq "macosx";
} else {
  sysRemoveDir($dir);
}
exit;

########################################################################################################################
sub checkCmd
{
  my @path = $os eq "windows" ? split(/;/, $ENV{path}) : split(/:/, $ENV{PATH});
  my @missing;
  foreach my $cmd (@_)
  {
    my $found = 0;
    foreach my $path (@path)
    {
      $found = 1 if $os eq "windows" && -f "$path\\$cmd\.EXE";
      $found = 1 if $os ne "windows" && -f "$path/$cmd";
    }
    push @missing, $cmd unless $found;
  }
  return if scalar(@missing) == 0;

  print "Could not find the following OS command(s): ",join(" ", @missing),
    "\n\nSearched the following directories:\n", join("\n", @path), "\n";
  exit;
}

sub sysCD
{
  my ($dir) = @_;
  print "cd $dir\n" if $debug;
  chdir($dir);
}

sub sysCopy
{
  my ($src,$dest) = @_;
  doSystem(($os eq "windows" ? "copy" : "cp")." \"$src\" \"$dest\"");
}

sub sysRemoveDir
{
  my ($dir) = @_;
  doSystem(($os eq "windows" ? "rmdir /S /Q" : "rm -R")." \"$dir\"");
}

sub sysUnzip
{
  my ($args,@targets) = @_;
  map { $_ = "\"$_\"" } @targets;
  doSystem(join(" ","unzip",$args,@targets));
}

sub sysZip
{
  my ($args,@targets) = @_;
  map { $_ = "\"$_\"" } @targets;
  doSystem(join(" ","zip",$args,@targets));
}

sub doSystem
{
    print "@_\n" if $debug;
    system "@_";
}

########################################################################################################################
sub doHelp
{
  print $helpMessage;
}