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