summaryrefslogtreecommitdiff
path: root/IkiWiki/Rcs/svn.pm
blob: fbf6b2c9ecc7be2556afe95cfa0ab11216731734 (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. # svn needs LC_CTYPE set to a UTF-8 locale, so try to find one. Any will do.
  8. sub find_lc_ctype() {
  9. my $current = setlocale(LC_CTYPE());
  10. return $current if $current =~ m/UTF-?8$/i;
  11. # Make some obvious attempts to avoid calling `locale -a`
  12. foreach my $locale ("$current.UTF-8", "en_US.UTF-8", "en_GB.UTF-8") {
  13. return $locale if setlocale(LC_CTYPE(), $locale);
  14. }
  15. # Try to get all available locales and pick the first UTF-8 one found.
  16. if (my @locale = grep(/UTF-?8$/i, `locale -a`)) {
  17. chomp @locale;
  18. return $locale[0] if setlocale(LC_CTYPE(), $locale[0]);
  19. }
  20. # fallback to the current locale
  21. return $current;
  22. } # }}}
  23. $ENV{LC_CTYPE} = $ENV{LC_CTYPE} || find_lc_ctype();
  24. sub svn_info ($$) { #{{{
  25. my $field=shift;
  26. my $file=shift;
  27. my $info=`LANG=C svn info $file`;
  28. my ($ret)=$info=~/^$field: (.*)$/m;
  29. return $ret;
  30. } #}}}
  31. sub rcs_update () { #{{{
  32. if (-d "$config{srcdir}/.svn") {
  33. if (system("svn", "update", "--quiet", $config{srcdir}) != 0) {
  34. warn("svn update failed\n");
  35. }
  36. }
  37. } #}}}
  38. sub rcs_prepedit ($) { #{{{
  39. # Prepares to edit a file under revision control. Returns a token
  40. # that must be passed into rcs_commit when the file is ready
  41. # for committing.
  42. # The file is relative to the srcdir.
  43. my $file=shift;
  44. if (-d "$config{srcdir}/.svn") {
  45. # For subversion, return the revision of the file when
  46. # editing begins.
  47. my $rev=svn_info("Revision", "$config{srcdir}/$file");
  48. return defined $rev ? $rev : "";
  49. }
  50. } #}}}
  51. sub rcs_commit ($$$) { #{{{
  52. # Tries to commit the page; returns undef on _success_ and
  53. # a version of the page with the rcs's conflict markers on failure.
  54. # The file is relative to the srcdir.
  55. my $file=shift;
  56. my $message=shift;
  57. my $rcstoken=shift;
  58. if (-d "$config{srcdir}/.svn") {
  59. # Check to see if the page has been changed by someone
  60. # else since rcs_prepedit was called.
  61. my ($oldrev)=$rcstoken=~/^([0-9]+)$/; # untaint
  62. my $rev=svn_info("Revision", "$config{srcdir}/$file");
  63. if (defined $rev && defined $oldrev && $rev != $oldrev) {
  64. # Merge their changes into the file that we've
  65. # changed.
  66. chdir($config{srcdir}); # svn merge wants to be here
  67. if (system("svn", "merge", "--quiet", "-r$oldrev:$rev",
  68. "$config{srcdir}/$file") != 0) {
  69. warn("svn merge -r$oldrev:$rev failed\n");
  70. }
  71. }
  72. if (system("svn", "commit", "--quiet",
  73. "--encoding", "UTF-8", "-m",
  74. possibly_foolish_untaint($message),
  75. "$config{srcdir}") != 0) {
  76. my $conflict=readfile("$config{srcdir}/$file");
  77. if (system("svn", "revert", "--quiet", "$config{srcdir}/$file") != 0) {
  78. warn("svn revert failed\n");
  79. }
  80. return $conflict;
  81. }
  82. }
  83. return undef # success
  84. } #}}}
  85. sub rcs_add ($) { #{{{
  86. # filename is relative to the root of the srcdir
  87. my $file=shift;
  88. if (-d "$config{srcdir}/.svn") {
  89. my $parent=dirname($file);
  90. while (! -d "$config{srcdir}/$parent/.svn") {
  91. $file=$parent;
  92. $parent=dirname($file);
  93. }
  94. if (system("svn", "add", "--quiet", "$config{srcdir}/$file") != 0) {
  95. warn("svn add failed\n");
  96. }
  97. }
  98. } #}}}
  99. sub rcs_recentchanges ($) { #{{{
  100. my $num=shift;
  101. my @ret;
  102. return unless -d "$config{srcdir}/.svn";
  103. eval q{
  104. use Date::Parse;
  105. use Time::Duration;
  106. use XML::SAX;
  107. use XML::Simple;
  108. };
  109. error($@) if $@;
  110. # avoid using XML::SAX::PurePerl, it's buggy with UTF-8 data
  111. my @parsers = map { ${$_}{Name} } @{XML::SAX->parsers()};
  112. do {
  113. $XML::Simple::PREFERRED_PARSER = pop @parsers;
  114. } until $XML::Simple::PREFERRED_PARSER ne 'XML::SAX::PurePerl';
  115. # --limit is only supported on Subversion 1.2.0+
  116. my $svn_version=`svn --version -q`;
  117. my $svn_limit='';
  118. $svn_limit="--limit $num"
  119. if $svn_version =~ /\d\.(\d)\.\d/ && $1 >= 2;
  120. my $svn_url=svn_info("URL", $config{srcdir});
  121. my $xml = XMLin(scalar `svn $svn_limit --xml -v log '$svn_url'`,
  122. ForceArray => [ 'logentry', 'path' ],
  123. GroupTags => { paths => 'path' },
  124. KeyAttr => { path => 'content' },
  125. );
  126. foreach my $logentry (@{$xml->{logentry}}) {
  127. my (@pages, @message);
  128. my $rev = $logentry->{revision};
  129. my $user = $logentry->{author};
  130. my $when=time - str2time($logentry->{date}, 'UTC');
  131. foreach my $msgline (split(/\n/, $logentry->{msg})) {
  132. push @message, { line => $msgline };
  133. }
  134. my $committype="web";
  135. if (defined $message[0] &&
  136. $message[0]->{line}=~/$config{web_commit_regexp}/) {
  137. $user=defined $2 ? "$2" : "$3";
  138. $message[0]->{line}=$4;
  139. }
  140. else {
  141. $committype="svn";
  142. }
  143. foreach (keys %{$logentry->{paths}}) {
  144. next unless /^\/\Q$config{svnpath}\E\/([^ ]+)(?:$|\s)/;
  145. my $file=$1;
  146. my $diffurl=$config{diffurl};
  147. $diffurl=~s/\[\[file\]\]/$file/g;
  148. $diffurl=~s/\[\[r1\]\]/$rev - 1/eg;
  149. $diffurl=~s/\[\[r2\]\]/$rev/g;
  150. push @pages, {
  151. page => pagename($file),
  152. diffurl => $diffurl,
  153. } if length $file;
  154. }
  155. push @ret, { rev => $rev,
  156. user => $user,
  157. committype => $committype,
  158. when => $when,
  159. message => [@message],
  160. pages => [@pages],
  161. } if @pages;
  162. return @ret if @ret >= $num;
  163. }
  164. return @ret;
  165. } #}}}
  166. sub rcs_notify () { #{{{
  167. if (! exists $ENV{REV}) {
  168. error("REV is not set, not running from svn post-commit hook, cannot send notifications");
  169. }
  170. my $rev=int(possibly_foolish_untaint($ENV{REV}));
  171. my $user=`svnlook author $config{svnrepo} -r $rev`;
  172. chomp $user;
  173. my $message=`svnlook log $config{svnrepo} -r $rev`;
  174. if ($message=~/$config{web_commit_regexp}/) {
  175. $user=defined $2 ? "$2" : "$3";
  176. $message=$4;
  177. }
  178. my @changed_pages;
  179. foreach my $change (`svnlook changed $config{svnrepo} -r $rev`) {
  180. chomp $change;
  181. if ($change =~ /^[A-Z]+\s+\Q$config{svnpath}\E\/(.*)/) {
  182. push @changed_pages, $1;
  183. }
  184. }
  185. require IkiWiki::UserInfo;
  186. send_commit_mails(
  187. sub {
  188. return $message;
  189. },
  190. sub {
  191. `svnlook diff $config{svnrepo} -r $rev --no-diff-deleted`;
  192. }, $user, @changed_pages);
  193. } #}}}
  194. sub rcs_getctime ($) { #{{{
  195. my $file=shift;
  196. my $svn_log_infoline=qr/^r\d+\s+\|\s+[^\s]+\s+\|\s+(\d+-\d+-\d+\s+\d+:\d+:\d+\s+[-+]?\d+).*/;
  197. my $child = open(SVNLOG, "-|");
  198. if (! $child) {
  199. exec("svn", "log", $file) || error("svn log $file failed to run");
  200. }
  201. my $date;
  202. while (<SVNLOG>) {
  203. if (/$svn_log_infoline/) {
  204. $date=$1;
  205. }
  206. }
  207. close SVNLOG || warn "svn log $file exited $?";
  208. if (! defined $date) {
  209. warn "failed to parse svn log for $file\n";
  210. return 0;
  211. }
  212. eval q{use Date::Parse};
  213. error($@) if $@;
  214. $date=str2time($date);
  215. debug("found ctime ".localtime($date)." for $file");
  216. return $date;
  217. } #}}}
  218. 1