summaryrefslogtreecommitdiff
path: root/IkiWiki/Plugin/mercurial.pm
blob: 11fdec529373c6b430a8e77bebb2c0a3aa6972b7 (plain)
  1. #!/usr/bin/perl
  2. package IkiWiki::Plugin::mercurial;
  3. use warnings;
  4. use strict;
  5. use IkiWiki;
  6. use Encode;
  7. use open qw{:utf8 :std};
  8. sub import {
  9. hook(type => "checkconfig", id => "mercurial", call => \&checkconfig);
  10. hook(type => "getsetup", id => "mercurial", call => \&getsetup);
  11. hook(type => "rcs", id => "rcs_update", call => \&rcs_update);
  12. hook(type => "rcs", id => "rcs_prepedit", call => \&rcs_prepedit);
  13. hook(type => "rcs", id => "rcs_commit", call => \&rcs_commit);
  14. hook(type => "rcs", id => "rcs_commit_staged", call => \&rcs_commit_staged);
  15. hook(type => "rcs", id => "rcs_add", call => \&rcs_add);
  16. hook(type => "rcs", id => "rcs_remove", call => \&rcs_remove);
  17. hook(type => "rcs", id => "rcs_rename", call => \&rcs_rename);
  18. hook(type => "rcs", id => "rcs_recentchanges", call => \&rcs_recentchanges);
  19. hook(type => "rcs", id => "rcs_diff", call => \&rcs_diff);
  20. hook(type => "rcs", id => "rcs_getctime", call => \&rcs_getctime);
  21. }
  22. sub checkconfig () {
  23. if (exists $config{mercurial_wrapper} && length $config{mercurial_wrapper}) {
  24. push @{$config{wrappers}}, {
  25. wrapper => $config{mercurial_wrapper},
  26. wrappermode => (defined $config{mercurial_wrappermode} ? $config{mercurial_wrappermode} : "06755"),
  27. };
  28. }
  29. }
  30. sub getsetup () {
  31. return
  32. plugin => {
  33. safe => 0, # rcs plugin
  34. rebuild => undef,
  35. },
  36. mercurial_wrapper => {
  37. type => "string",
  38. #example => # FIXME add example
  39. description => "mercurial post-commit hook to generate",
  40. safe => 0, # file
  41. rebuild => 0,
  42. },
  43. mercurial_wrappermode => {
  44. type => "string",
  45. example => '06755',
  46. description => "mode for mercurial_wrapper (can safely be made suid)",
  47. safe => 0,
  48. rebuild => 0,
  49. },
  50. historyurl => {
  51. type => "string",
  52. example => "http://example.com:8000/log/tip/[[file]]",
  53. description => "url to hg serve'd repository, to show file history ([[file]] substituted)",
  54. safe => 1,
  55. rebuild => 1,
  56. },
  57. diffurl => {
  58. type => "string",
  59. example => "http://localhost:8000/?fd=[[r2]];file=[[file]]",
  60. description => "url to hg serve'd repository, to show diff ([[file]] and [[r2]] substituted)",
  61. safe => 1,
  62. rebuild => 1,
  63. },
  64. }
  65. sub mercurial_log ($) {
  66. my $out = shift;
  67. my @infos;
  68. while (<$out>) {
  69. my $line = $_;
  70. my ($key, $value);
  71. if (/^description:/) {
  72. $key = "description";
  73. $value = "";
  74. # slurp everything as the description text
  75. # until the next changeset
  76. while (<$out>) {
  77. if (/^changeset: /) {
  78. $line = $_;
  79. last;
  80. }
  81. $value .= $_;
  82. }
  83. local $/ = "";
  84. chomp $value;
  85. $infos[$#infos]{$key} = $value;
  86. }
  87. chomp $line;
  88. ($key, $value) = split /: +/, $line, 2;
  89. if ($key eq "changeset") {
  90. push @infos, {};
  91. # remove the revision index, which is strictly
  92. # local to the repository
  93. $value =~ s/^\d+://;
  94. }
  95. $infos[$#infos]{$key} = $value;
  96. }
  97. close $out;
  98. return @infos;
  99. }
  100. sub rcs_update () {
  101. my @cmdline = ("hg", "-q", "-R", "$config{srcdir}", "update");
  102. if (system(@cmdline) != 0) {
  103. warn "'@cmdline' failed: $!";
  104. }
  105. }
  106. sub rcs_prepedit ($) {
  107. return "";
  108. }
  109. sub rcs_commit ($$$;$$) {
  110. my ($file, $message, $rcstoken, $user, $ipaddr) = @_;
  111. if (defined $user) {
  112. $user = IkiWiki::possibly_foolish_untaint($user);
  113. }
  114. elsif (defined $ipaddr) {
  115. $user = "Anonymous from ".IkiWiki::possibly_foolish_untaint($ipaddr);
  116. }
  117. else {
  118. $user = "Anonymous";
  119. }
  120. $message = IkiWiki::possibly_foolish_untaint($message);
  121. if (! length $message) {
  122. $message = "no message given";
  123. }
  124. my @cmdline = ("hg", "-q", "-R", $config{srcdir}, "commit",
  125. "-m", $message, "-u", $user);
  126. if (system(@cmdline) != 0) {
  127. warn "'@cmdline' failed: $!";
  128. }
  129. return undef; # success
  130. }
  131. sub rcs_commit_staged ($$$) {
  132. # Commits all staged changes. Changes can be staged using rcs_add,
  133. # rcs_remove, and rcs_rename.
  134. my ($message, $user, $ipaddr)=@_;
  135. error("rcs_commit_staged not implemented for mercurial"); # TODO
  136. }
  137. sub rcs_add ($) {
  138. my ($file) = @_;
  139. my @cmdline = ("hg", "-q", "-R", "$config{srcdir}", "add", "$config{srcdir}/$file");
  140. if (system(@cmdline) != 0) {
  141. warn "'@cmdline' failed: $!";
  142. }
  143. }
  144. sub rcs_remove ($) {
  145. my ($file) = @_;
  146. error("rcs_remove not implemented for mercurial"); # TODO
  147. }
  148. sub rcs_rename ($$) {
  149. my ($src, $dest) = @_;
  150. error("rcs_rename not implemented for mercurial"); # TODO
  151. }
  152. sub rcs_recentchanges ($) {
  153. my ($num) = @_;
  154. my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v", "-l", $num,
  155. "--style", "default");
  156. open (my $out, "@cmdline |");
  157. eval q{use Date::Parse};
  158. error($@) if $@;
  159. my @ret;
  160. foreach my $info (mercurial_log($out)) {
  161. my @pages = ();
  162. my @message = ();
  163. foreach my $msgline (split(/\n/, $info->{description})) {
  164. push @message, { line => $msgline };
  165. }
  166. foreach my $file (split / /,$info->{files}) {
  167. my $diffurl = defined $config{diffurl} ? $config{'diffurl'} : "";
  168. $diffurl =~ s/\[\[file\]\]/$file/go;
  169. $diffurl =~ s/\[\[r2\]\]/$info->{changeset}/go;
  170. push @pages, {
  171. page => pagename($file),
  172. diffurl => $diffurl,
  173. };
  174. }
  175. my $user = $info->{"user"};
  176. $user =~ s/\s*<.*>\s*$//;
  177. $user =~ s/^\s*//;
  178. push @ret, {
  179. rev => $info->{"changeset"},
  180. user => $user,
  181. committype => "hg",
  182. when => str2time($info->{"date"}),
  183. message => [@message],
  184. pages => [@pages],
  185. };
  186. }
  187. return @ret;
  188. }
  189. sub rcs_diff ($) {
  190. # TODO
  191. }
  192. sub rcs_getctime ($) {
  193. my ($file) = @_;
  194. # XXX filename passes through the shell here, should try to avoid
  195. # that just in case
  196. my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v",
  197. "--style", "default", "$config{srcdir}/$file");
  198. open (my $out, "@cmdline |");
  199. my @log = mercurial_log($out);
  200. if (length @log < 1) {
  201. return 0;
  202. }
  203. eval q{use Date::Parse};
  204. error($@) if $@;
  205. my $ctime = str2time($log[$#log]->{"date"});
  206. return $ctime;
  207. }
  208. 1