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