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