summaryrefslogtreecommitdiff
path: root/IkiWiki/Rcs/tla.pm
blob: 48dc78157ae95b5406a6fdf61b04bb236c1f4a91 (plain)
  1. #!/usr/bin/perl
  2. use warnings;
  3. use strict;
  4. use IkiWiki;
  5. use POSIX qw(setlocale LC_CTYPE);
  6. package IkiWiki;
  7. my $tla_webcommit=qr/^web commit (by (\w+)|from (\d+\.\d+\.\d+\.\d+)):?(.*)/;
  8. sub quiet_system (@) {
  9. # See Debian bug #385939.
  10. open (SAVEOUT, ">&STDOUT");
  11. close STDOUT;
  12. my $ret=system(@_);
  13. open (STDOUT, ">&SAVEOUT");
  14. close SAVEOUT;
  15. return $ret;
  16. }
  17. sub rcs_update () { #{{{
  18. if (-d "$config{srcdir}/{arch}") {
  19. if (quiet_system("tla", "replay", "-d", $config{srcdir}) != 0) {
  20. warn("tla replay failed\n");
  21. }
  22. }
  23. } #}}}
  24. sub rcs_prepedit ($) { #{{{
  25. my $file=shift;
  26. if (-d "$config{srcdir}/{arch}") {
  27. # For Arch, return the tree-id of archive when
  28. # editing begins.
  29. my $rev=`tla tree-id $config{srcdir}`;
  30. return defined $rev ? $rev : "";
  31. }
  32. } #}}}
  33. sub rcs_commit ($$$) { #{{{
  34. my $file=shift;
  35. my $message=shift;
  36. my $rcstoken=shift;
  37. if (-d "$config{srcdir}/{arch}") {
  38. # Check to see if the page has been changed by someone
  39. # else since rcs_prepedit was called.
  40. my ($oldrev)=$rcstoken=~/^([A-Za-z0-9@\/._-]+)$/; # untaint
  41. my $rev=`tla tree-id $config{srcdir}`;
  42. if (defined $rev && defined $oldrev && $rev ne $oldrev) {
  43. # Merge their changes into the file that we've
  44. # changed.
  45. if (system("tla", "update", "-d",
  46. "$config{srcdir}/$file") != 0) {
  47. warn("tla update failed\n");
  48. }
  49. }
  50. if (quiet_system("tla", "commit",
  51. "-L".possibly_foolish_untaint($message),
  52. '-d', $config{srcdir}) != 0) {
  53. my $conflict=readfile("$config{srcdir}/$file");
  54. if (system("tla", "undo", "--quiet", "-d", "$config{srcdir}") != 0) {
  55. warn("tla undo failed\n");
  56. }
  57. return $conflict;
  58. }
  59. }
  60. return undef # success
  61. } #}}}
  62. sub rcs_add ($) { #{{{
  63. my $file=shift;
  64. if (-d "$config{srcdir}/{arch}") {
  65. if (quiet_system("tla", "add", "$config{srcdir}/$file") != 0) {
  66. warn("tla add failed\n");
  67. }
  68. }
  69. } #}}}
  70. sub rcs_recentchanges ($) {
  71. my $num=shift;
  72. my @ret;
  73. return unless -d "$config{srcdir}/{arch}";
  74. eval q{use Date::Parse};
  75. eval q{use Mail::Header};
  76. my $logs = `tla logs -d $config{srcdir}`;
  77. my @changesets = reverse split(/\n/, $logs);
  78. for (my $i=0; $i<$num && $i<$#changesets; $i++) {
  79. my ($change)=$changesets[$i]=~/^([A-Za-z0-9@\/._-]+)$/; # untaint
  80. open(LOG, "tla cat-log -d $config{srcdir} $change|");
  81. my $head = Mail::Header->new(\*LOG);
  82. close(LOG);
  83. my $rev = $head->get("Revision");
  84. my $summ = $head->get("Summary");
  85. my $newfiles = $head->get("New-files");
  86. my $modfiles = $head->get("Modified-files");
  87. my $user = $head->get("Creator");
  88. my @paths = grep {!/^.*\/\.arch-ids\/.*\.id$/} split(/ /,
  89. "$newfiles $modfiles");
  90. my $sdate = $head->get("Standard-date");
  91. my $when = time - str2time($sdate, 'UTC');
  92. my $committype = "web";
  93. if (defined $summ && $summ =~ /$tla_webcommit/) {
  94. $user = defined $2 ? "$2" : "$3";
  95. $summ = $4;
  96. }
  97. else {
  98. $committype="tla";
  99. }
  100. my @message;
  101. push @message, { line => escapeHTML($summ) };
  102. $user = escapeHTML($user);
  103. my @pages;
  104. foreach my $file (@paths) {
  105. my $diffurl=$config{diffurl};
  106. $diffurl=~s/\[\[file\]\]/$file/g;
  107. $diffurl=~s/\[\[rev\]\]/$change/g;
  108. push @pages, {
  109. page => pagename($file),
  110. diffurl => $diffurl,
  111. } if length $file;
  112. }
  113. push @ret, { rev => $change,
  114. user => $user,
  115. committype => $committype,
  116. when => $when,
  117. message => [@message],
  118. pages => [@pages],
  119. } if @pages;
  120. last if $i == $num;
  121. }
  122. return @ret;
  123. }
  124. sub rcs_notify () { #{{{
  125. # FIXME: Not set
  126. if (! exists $ENV{REV}) {
  127. error("REV is not set, not running from tla post-commit hook, cannot send notifications");
  128. }
  129. my $rev=int(possibly_foolish_untaint($ENV{REV}));
  130. eval q{use Mail::Header};
  131. open(LOG, $ENV{"ARCH_LOG"});
  132. my $head = Mail::Header->new(\*LOG);
  133. close(LOG);
  134. my $message = $head->get("Summary");
  135. my $user = $head->get("Creator");
  136. my $newfiles = $head->get("New-files");
  137. my $modfiles = $head->get("Modified-files");
  138. my @changed_pages = grep {!/^.*\/\.arch-ids\/.*\.id$/} split(/ /,
  139. "$newfiles $modfiles");
  140. if ($message =~ /$tla_webcommit/) {
  141. $user=defined $2 ? "$2" : "$3";
  142. $message=$4;
  143. }
  144. require IkiWiki::UserInfo;
  145. my @email_recipients=commit_notify_list($user, @changed_pages);
  146. if (@email_recipients) {
  147. # TODO: if a commit spans multiple pages, this will send
  148. # subscribers a diff that might contain pages they did not
  149. # sign up for. Should separate the diff per page and
  150. # reassemble into one mail with just the pages subscribed to.
  151. my $logs = `tla logs -d $config{srcdir}`;
  152. my @changesets = reverse split(/\n/, $logs);
  153. my $i;
  154. for($i=0;$i<$#changesets;$i++) {
  155. last if $changesets[$i] eq $rev;
  156. }
  157. my $revminusone = $changesets[$i+1];
  158. my $diff=`tla diff -d $ENV{ARCH_TREE_ROOT} $revminusone`;
  159. my $subject="$config{wikiname} update of ";
  160. if (@changed_pages > 2) {
  161. $subject.="$changed_pages[0] $changed_pages[1] etc";
  162. }
  163. else {
  164. $subject.=join(" ", @changed_pages);
  165. }
  166. $subject.=" by $user";
  167. my $template=template("notifymail.tmpl");
  168. $template->param(
  169. wikiname => $config{wikiname},
  170. diff => $diff,
  171. user => $user,
  172. message => $message,
  173. );
  174. eval q{use Mail::Sendmail};
  175. foreach my $email (@email_recipients) {
  176. sendmail(
  177. To => $email,
  178. From => "$config{wikiname} <$config{adminemail}>",
  179. Subject => $subject,
  180. Message => $template->output,
  181. ) or error("Failed to send update notification mail");
  182. }
  183. }
  184. } #}}}
  185. sub rcs_getctime ($) { #{{{
  186. my $file=shift;
  187. eval q{use Date::Parse};
  188. eval q{use Mail::Header};
  189. my $logs = `tla logs -d $config{srcdir}`;
  190. my @changesets = reverse split(/\n/, $logs);
  191. my $sdate;
  192. for (my $i=0; $i<$#changesets; $i++) {
  193. my $change = $changesets[$i];
  194. open(LOG, "tla cat-log -d $config{srcdir} $change|");
  195. my $head = Mail::Header->new(\*LOG);
  196. close(LOG);
  197. $sdate = $head->get("Standard-date");
  198. my $newfiles = $head->get("New-files");
  199. my ($lastcreation) = grep {/^$file$/} split(/ /, "$newfiles");
  200. last if defined($lastcreation);
  201. }
  202. my $date=str2time($sdate, 'UTC');
  203. debug("found ctime ".localtime($date)." for $file");
  204. return $date;
  205. } #}}}
  206. 1