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