summaryrefslogtreecommitdiff
path: root/IkiWiki/Rcs/tla.pm
blob: 5275500c395b5031bfbf627e5d31531abff41a8e (plain)
  1. #!/usr/bin/perl
  2. use warnings;
  3. use strict;
  4. use IkiWiki;
  5. package IkiWiki;
  6. sub quiet_system (@) {
  7. # See Debian bug #385939.
  8. open (SAVEOUT, ">&STDOUT");
  9. close STDOUT;
  10. open (STDOUT, ">/dev/null");
  11. my $ret=system(@_);
  12. close STDOUT;
  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. my $user=shift;
  38. my $ipaddr=shift;
  39. if (defined $user) {
  40. $message="web commit by $user".(length $message ? ": $message" : "");
  41. }
  42. elsif (defined $ipaddr) {
  43. $message="web commit from $ipaddr".(length $message ? ": $message" : "");
  44. }
  45. if (-d "$config{srcdir}/{arch}") {
  46. # Check to see if the page has been changed by someone
  47. # else since rcs_prepedit was called.
  48. my ($oldrev)=$rcstoken=~/^([A-Za-z0-9@\/._-]+)$/; # untaint
  49. my $rev=`tla tree-id $config{srcdir}`;
  50. if (defined $rev && defined $oldrev && $rev ne $oldrev) {
  51. # Merge their changes into the file that we've
  52. # changed.
  53. if (quiet_system("tla", "update", "-d",
  54. "$config{srcdir}") != 0) {
  55. warn("tla update failed\n");
  56. }
  57. }
  58. if (quiet_system("tla", "commit",
  59. "-L".possibly_foolish_untaint($message),
  60. '-d', $config{srcdir}) != 0) {
  61. my $conflict=readfile("$config{srcdir}/$file");
  62. if (system("tla", "undo", "-n", "--quiet", "-d", "$config{srcdir}") != 0) {
  63. warn("tla undo failed\n");
  64. }
  65. return $conflict;
  66. }
  67. }
  68. return undef # success
  69. } #}}}
  70. sub rcs_add ($) { #{{{
  71. my $file=shift;
  72. if (-d "$config{srcdir}/{arch}") {
  73. if (quiet_system("tla", "add", "$config{srcdir}/$file") != 0) {
  74. warn("tla add failed\n");
  75. }
  76. }
  77. } #}}}
  78. sub rcs_recentchanges ($) {
  79. my $num=shift;
  80. my @ret;
  81. return unless -d "$config{srcdir}/{arch}";
  82. eval q{use Date::Parse};
  83. error($@) if $@;
  84. eval q{use Mail::Header};
  85. error($@) if $@;
  86. my $logs = `tla logs -d $config{srcdir}`;
  87. my @changesets = reverse split(/\n/, $logs);
  88. for (my $i=0; $i<$num && $i<$#changesets; $i++) {
  89. my ($change)=$changesets[$i]=~/^([A-Za-z0-9@\/._-]+)$/; # untaint
  90. open(LOG, "tla cat-log -d $config{srcdir} $change|");
  91. my $head = Mail::Header->new(\*LOG);
  92. close(LOG);
  93. my $rev = $head->get("Revision");
  94. my $summ = $head->get("Summary");
  95. my $newfiles = $head->get("New-files");
  96. my $modfiles = $head->get("Modified-files");
  97. my $remfiles = $head->get("Removed-files");
  98. my $user = $head->get("Creator");
  99. my @paths = grep { !/^(.*\/)?\.arch-ids\/.*\.id$/ }
  100. split(/ /, "$newfiles $modfiles .arch-ids/fake.id");
  101. my $sdate = $head->get("Standard-date");
  102. my $when = time - str2time($sdate, 'UTC');
  103. my $committype = "web";
  104. if (defined $summ && $summ =~ /$config{web_commit_regexp}/) {
  105. $user = defined $2 ? "$2" : "$3";
  106. $summ = $4;
  107. }
  108. else {
  109. $committype="tla";
  110. }
  111. my @message;
  112. push @message, { line => escapeHTML($summ) };
  113. my @pages;
  114. foreach my $file (@paths) {
  115. my $diffurl=$config{diffurl};
  116. $diffurl=~s/\[\[file\]\]/$file/g;
  117. $diffurl=~s/\[\[rev\]\]/$change/g;
  118. push @pages, {
  119. page => pagename($file),
  120. diffurl => $diffurl,
  121. } if length $file;
  122. }
  123. push @ret, {
  124. id => $change,
  125. user => $user,
  126. committype => $committype,
  127. when => $when,
  128. message => [@message],
  129. pages => [@pages],
  130. } if @pages;
  131. last if $i == $num;
  132. }
  133. return @ret;
  134. }
  135. sub rcs_notify () { #{{{
  136. # FIXME: Not set
  137. if (! exists $ENV{ARCH_VERSION}) {
  138. error("ARCH_VERSION is not set, not running from tla post-commit hook, cannot send notifications");
  139. }
  140. my $rev=int(possibly_foolish_untaint($ENV{REV}));
  141. eval q{use Mail::Header};
  142. error($@) if $@;
  143. open(LOG, $ENV{"ARCH_LOG"});
  144. my $head = Mail::Header->new(\*LOG);
  145. close(LOG);
  146. my $user = $head->get("Creator");
  147. my $newfiles = $head->get("New-files");
  148. my $modfiles = $head->get("Modified-files");
  149. my $remfiles = $head->get("Removed-files");
  150. my @changed_pages = grep { !/(^.*\/)?\.arch-ids\/.*\.id$/ }
  151. split(/ /, "$newfiles $modfiles $remfiles .arch-ids/fake.id");
  152. require IkiWiki::UserInfo;
  153. send_commit_mails(
  154. sub {
  155. my $message = $head->get("Summary");
  156. if ($message =~ /$config{web_commit_regexp}/) {
  157. $user=defined $2 ? "$2" : "$3";
  158. $message=$4;
  159. }
  160. },
  161. sub {
  162. my $logs = `tla logs -d $config{srcdir}`;
  163. my @changesets = reverse split(/\n/, $logs);
  164. my $i;
  165. for($i=0;$i<$#changesets;$i++) {
  166. last if $changesets[$i] eq $rev;
  167. }
  168. my $revminusone = $changesets[$i+1];
  169. `tla diff -d $ENV{ARCH_TREE_ROOT} $revminusone`;
  170. }, $user, @changed_pages);
  171. } #}}}
  172. sub rcs_getctime ($) { #{{{
  173. my $file=shift;
  174. eval q{use Date::Parse};
  175. error($@) if $@;
  176. eval q{use Mail::Header};
  177. error($@) if $@;
  178. my $logs = `tla logs -d $config{srcdir}`;
  179. my @changesets = reverse split(/\n/, $logs);
  180. my $sdate;
  181. for (my $i=0; $i<$#changesets; $i++) {
  182. my $change = $changesets[$i];
  183. open(LOG, "tla cat-log -d $config{srcdir} $change|");
  184. my $head = Mail::Header->new(\*LOG);
  185. close(LOG);
  186. $sdate = $head->get("Standard-date");
  187. my $newfiles = $head->get("New-files");
  188. my ($lastcreation) = grep {/^$file$/} split(/ /, "$newfiles");
  189. last if defined($lastcreation);
  190. }
  191. my $date=str2time($sdate, 'UTC');
  192. debug("found ctime ".localtime($date)." for $file");
  193. return $date;
  194. } #}}}
  195. 1