]> git.vanrenterghem.biz Git - git.ikiwiki.info.git/blob - IkiWiki.pm
fix
[git.ikiwiki.info.git] / IkiWiki.pm
1 #!/usr/bin/perl
3 package IkiWiki;
4 use warnings;
5 use strict;
6 use Encode;
7 use HTML::Entities;
8 use open qw{:utf8 :std};
10 # Optimisation.
11 use Memoize;
12 memoize("abs2rel");
13 memoize("pagespec_translate");
15 use vars qw{%config %links %oldlinks %oldpagemtime %pagectime %pagecase
16             %renderedfiles %pagesources %depends %hooks %forcerebuild};
18 my $installdir=''; # INSTALLDIR_AUTOREPLACE done by Makefile, DNE
20 sub defaultconfig () { #{{{
21         wiki_file_prune_regexp => qr{((^|/).svn/|\.\.|^\.|\/\.|\.x?html?$|\.rss$)},
22         wiki_link_regexp => qr/\[\[(?:([^\]\|]+)\|)?([^\s\]]+)\]\]/,
23         wiki_file_regexp => qr/(^[-[:alnum:]_.:\/+]+$)/,
24         verbose => 0,
25         syslog => 0,
26         wikiname => "wiki",
27         default_pageext => "mdwn",
28         cgi => 0,
29         rcs => 'svn',
30         notify => 0,
31         url => '',
32         cgiurl => '',
33         historyurl => '',
34         diffurl => '',
35         anonok => 0,
36         rss => 0,
37         discussion => 1,
38         rebuild => 0,
39         refresh => 0,
40         getctime => 0,
41         w3mmode => 0,
42         wrapper => undef,
43         wrappermode => undef,
44         svnrepo => undef,
45         svnpath => "trunk",
46         srcdir => undef,
47         destdir => undef,
48         pingurl => [],
49         templatedir => "$installdir/share/ikiwiki/templates",
50         underlaydir => "$installdir/share/ikiwiki/basewiki",
51         setup => undef,
52         adminuser => undef,
53         adminemail => undef,
54         plugin => [qw{mdwn inline htmlscrubber}],
55         timeformat => '%c',
56         locale => undef,
57         sslcookie => 0,
58 } #}}}
59    
60 sub checkconfig () { #{{{
61         # locale stuff; avoid LC_ALL since it overrides everything
62         if (defined $ENV{LC_ALL}) {
63                 $ENV{LANG} = $ENV{LC_ALL};
64                 delete $ENV{LC_ALL};
65         }
66         if (defined $config{locale}) {
67                 eval q{use POSIX};
68                 $ENV{LANG} = $config{locale}
69                         if POSIX::setlocale(&POSIX::LC_TIME, $config{locale});
70         }
72         if ($config{w3mmode}) {
73                 eval q{use Cwd q{abs_path}};
74                 $config{srcdir}=possibly_foolish_untaint(abs_path($config{srcdir}));
75                 $config{destdir}=possibly_foolish_untaint(abs_path($config{destdir}));
76                 $config{cgiurl}="file:///\$LIB/ikiwiki-w3m.cgi/".$config{cgiurl}
77                         unless $config{cgiurl} =~ m!file:///!;
78                 $config{url}="file://".$config{destdir};
79         }
81         if ($config{cgi} && ! length $config{url}) {
82                 error("Must specify url to wiki with --url when using --cgi\n");
83         }
84         if ($config{rss} && ! length $config{url}) {
85                 error("Must specify url to wiki with --url when using --rss\n");
86         }
87         
88         $config{wikistatedir}="$config{srcdir}/.ikiwiki"
89                 unless exists $config{wikistatedir};
90         
91         if ($config{rcs}) {
92                 eval qq{require IkiWiki::Rcs::$config{rcs}};
93                 if ($@) {
94                         error("Failed to load RCS module IkiWiki::Rcs::$config{rcs}: $@");
95                 }
96         }
97         else {
98                 require IkiWiki::Rcs::Stub;
99         }
101         run_hooks(checkconfig => sub { shift->() });
102 } #}}}
104 sub loadplugins () { #{{{
105         foreach my $plugin (@{$config{plugin}}) {
106                 my $mod="IkiWiki::Plugin::".possibly_foolish_untaint($plugin);
107                 eval qq{use $mod};
108                 if ($@) {
109                         error("Failed to load plugin $mod: $@");
110                 }
111         }
112         run_hooks(getopt => sub { shift->() });
113         if (grep /^-/, @ARGV) {
114                 print STDERR "Unknown option: $_\n"
115                         foreach grep /^-/, @ARGV;
116                 usage();
117         }
118 } #}}}
120 sub error ($) { #{{{
121         if ($config{cgi}) {
122                 print "Content-type: text/html\n\n";
123                 print misctemplate("Error", "<p>Error: @_</p>");
124         }
125         log_message(error => @_);
126         exit(1);
127 } #}}}
129 sub debug ($) { #{{{
130         return unless $config{verbose};
131         log_message(debug => @_);
132 } #}}}
134 my $log_open=0;
135 sub log_message ($$) { #{{{
136         my $type=shift;
138         if ($config{syslog}) {
139                 require Sys::Syslog;
140                 unless ($log_open) {
141                         Sys::Syslog::setlogsock('unix');
142                         Sys::Syslog::openlog('ikiwiki', '', 'user');
143                         $log_open=1;
144                 }
145                 eval {
146                         Sys::Syslog::syslog($type, join(" ", @_));
147                 }
148         }
149         elsif (! $config{cgi}) {
150                 print "@_\n";
151         }
152         else {
153                 print STDERR "@_\n";
154         }
155 } #}}}
157 sub possibly_foolish_untaint ($) { #{{{
158         my $tainted=shift;
159         my ($untainted)=$tainted=~/(.*)/;
160         return $untainted;
161 } #}}}
163 sub basename ($) { #{{{
164         my $file=shift;
166         $file=~s!.*/+!!;
167         return $file;
168 } #}}}
170 sub dirname ($) { #{{{
171         my $file=shift;
173         $file=~s!/*[^/]+$!!;
174         return $file;
175 } #}}}
177 sub pagetype ($) { #{{{
178         my $page=shift;
179         
180         if ($page =~ /\.([^.]+)$/) {
181                 return $1 if exists $hooks{htmlize}{$1};
182         }
183         return undef;
184 } #}}}
186 sub pagename ($) { #{{{
187         my $file=shift;
189         my $type=pagetype($file);
190         my $page=$file;
191         $page=~s/\Q.$type\E*$// if defined $type;
192         return $page;
193 } #}}}
195 sub htmlpage ($) { #{{{
196         my $page=shift;
198         return $page.".html";
199 } #}}}
201 sub srcfile ($) { #{{{
202         my $file=shift;
204         return "$config{srcdir}/$file" if -e "$config{srcdir}/$file";
205         return "$config{underlaydir}/$file" if -e "$config{underlaydir}/$file";
206         error("internal error: $file cannot be found");
207 } #}}}
209 sub readfile ($;$) { #{{{
210         my $file=shift;
211         my $binary=shift;
213         if (-l $file) {
214                 error("cannot read a symlink ($file)");
215         }
216         
217         local $/=undef;
218         open (IN, $file) || error("failed to read $file: $!");
219         binmode(IN) if ($binary);
220         my $ret=<IN>;
221         close IN;
222         return $ret;
223 } #}}}
225 sub writefile ($$$;$) { #{{{
226         my $file=shift; # can include subdirs
227         my $destdir=shift; # directory to put file in
228         my $content=shift;
229         my $binary=shift;
230         
231         my $test=$file;
232         while (length $test) {
233                 if (-l "$destdir/$test") {
234                         error("cannot write to a symlink ($test)");
235                 }
236                 $test=dirname($test);
237         }
239         my $dir=dirname("$destdir/$file");
240         if (! -d $dir) {
241                 my $d="";
242                 foreach my $s (split(m!/+!, $dir)) {
243                         $d.="$s/";
244                         if (! -d $d) {
245                                 mkdir($d) || error("failed to create directory $d: $!");
246                         }
247                 }
248         }
249         
250         open (OUT, ">$destdir/$file") || error("failed to write $destdir/$file: $!");
251         binmode(OUT) if ($binary);
252         print OUT $content;
253         close OUT;
254 } #}}}
256 sub bestlink ($$) { #{{{
257         # Given a page and the text of a link on the page, determine which
258         # existing page that link best points to. Prefers pages under a
259         # subdirectory with the same name as the source page, failing that
260         # goes down the directory tree to the base looking for matching
261         # pages.
262         my $page=shift;
263         my $link=shift;
264         
265         my $cwd=$page;
266         do {
267                 my $l=$cwd;
268                 $l.="/" if length $l;
269                 $l.=$link;
271                 if (exists $links{$l}) {
272                         return $l;
273                 }
274                 elsif (exists $pagecase{lc $l}) {
275                         return $pagecase{lc $l};
276                 }
277         } while $cwd=~s!/?[^/]+$!!;
279         #print STDERR "warning: page $page, broken link: $link\n";
280         return "";
281 } #}}}
283 sub isinlinableimage ($) { #{{{
284         my $file=shift;
285         
286         $file=~/\.(png|gif|jpg|jpeg)$/i;
287 } #}}}
289 sub pagetitle ($) { #{{{
290         my $page=shift;
291         $page=~s/__(\d+)__/&#$1;/g;
292         $page=~y/_/ /;
293         return $page;
294 } #}}}
296 sub titlepage ($) { #{{{
297         my $title=shift;
298         $title=~y/ /_/;
299         $title=~s/([^-[:alnum:]_:+\/.])/"__".ord($1)."__"/eg;
300         return $title;
301 } #}}}
303 sub cgiurl (@) { #{{{
304         my %params=@_;
306         return $config{cgiurl}."?".join("&amp;", map "$_=$params{$_}", keys %params);
307 } #}}}
309 sub baseurl (;$) { #{{{
310         my $page=shift;
312         return "$config{url}/" if ! defined $page;
313         
314         $page=~s/[^\/]+$//;
315         $page=~s/[^\/]+\//..\//g;
316         return $page;
317 } #}}}
319 sub abs2rel ($$) { #{{{
320         # Work around very innefficient behavior in File::Spec if abs2rel
321         # is passed two relative paths. It's much faster if paths are
322         # absolute!
323         my $path="/".shift;
324         my $base="/".shift;
326         require File::Spec;
327         my $ret=File::Spec->abs2rel($path, $base);
328         $ret=~s/^// if defined $ret;
329         return $ret;
330 } #}}}
332 sub htmllink ($$$;$$$) { #{{{
333         my $lpage=shift; # the page doing the linking
334         my $page=shift; # the page that will contain the link (different for inline)
335         my $link=shift;
336         my $noimageinline=shift; # don't turn links into inline html images
337         my $forcesubpage=shift; # force a link to a subpage
338         my $linktext=shift; # set to force the link text to something
340         my $bestlink;
341         if (! $forcesubpage) {
342                 $bestlink=bestlink($lpage, $link);
343         }
344         else {
345                 $bestlink="$lpage/".lc($link);
346         }
348         $linktext=pagetitle(basename($link)) unless defined $linktext;
349         
350         return "<span class=\"selflink\">$linktext</span>"
351                 if length $bestlink && $page eq $bestlink;
352         
353         # TODO BUG: %renderedfiles may not have it, if the linked to page
354         # was also added and isn't yet rendered! Note that this bug is
355         # masked by the bug that makes all new files be rendered twice.
356         if (! grep { $_ eq $bestlink } values %renderedfiles) {
357                 $bestlink=htmlpage($bestlink);
358         }
359         if (! grep { $_ eq $bestlink } values %renderedfiles) {
360                 return "<span><a href=\"".
361                         cgiurl(do => "create", page => lc($link), from => $page).
362                         "\">?</a>$linktext</span>"
363         }
364         
365         $bestlink=abs2rel($bestlink, dirname($page));
366         
367         if (! $noimageinline && isinlinableimage($bestlink)) {
368                 return "<img src=\"$bestlink\" alt=\"$linktext\" />";
369         }
370         return "<a href=\"$bestlink\">$linktext</a>";
371 } #}}}
373 sub indexlink () { #{{{
374         return "<a href=\"$config{url}\">$config{wikiname}</a>";
375 } #}}}
377 sub lockwiki () { #{{{
378         # Take an exclusive lock on the wiki to prevent multiple concurrent
379         # run issues. The lock will be dropped on program exit.
380         if (! -d $config{wikistatedir}) {
381                 mkdir($config{wikistatedir});
382         }
383         open(WIKILOCK, ">$config{wikistatedir}/lockfile") ||
384                 error ("cannot write to $config{wikistatedir}/lockfile: $!");
385         if (! flock(WIKILOCK, 2 | 4)) {
386                 debug("wiki seems to be locked, waiting for lock");
387                 my $wait=600; # arbitrary, but don't hang forever to 
388                               # prevent process pileup
389                 for (1..600) {
390                         return if flock(WIKILOCK, 2 | 4);
391                         sleep 1;
392                 }
393                 error("wiki is locked; waited $wait seconds without lock being freed (possible stuck process or stale lock?)");
394         }
395 } #}}}
397 sub unlockwiki () { #{{{
398         close WIKILOCK;
399 } #}}}
401 sub loadindex () { #{{{
402         open (IN, "$config{wikistatedir}/index") || return;
403         while (<IN>) {
404                 $_=possibly_foolish_untaint($_);
405                 chomp;
406                 my %items;
407                 $items{link}=[];
408                 foreach my $i (split(/ /, $_)) {
409                         my ($item, $val)=split(/=/, $i, 2);
410                         push @{$items{$item}}, decode_entities($val);
411                 }
413                 next unless exists $items{src}; # skip bad lines for now
415                 my $page=pagename($items{src}[0]);
416                 if (! $config{rebuild}) {
417                         $pagesources{$page}=$items{src}[0];
418                         $oldpagemtime{$page}=$items{mtime}[0];
419                         $oldlinks{$page}=[@{$items{link}}];
420                         $links{$page}=[@{$items{link}}];
421                         $depends{$page}=$items{depends}[0] if exists $items{depends};
422                         $renderedfiles{$page}=$items{dest}[0];
423                         $pagecase{lc $page}=$page;
424                 }
425                 $pagectime{$page}=$items{ctime}[0];
426         }
427         close IN;
428 } #}}}
430 sub saveindex () { #{{{
431         run_hooks(savestate => sub { shift->() });
433         if (! -d $config{wikistatedir}) {
434                 mkdir($config{wikistatedir});
435         }
436         open (OUT, ">$config{wikistatedir}/index") || 
437                 error("cannot write to $config{wikistatedir}/index: $!");
438         foreach my $page (keys %oldpagemtime) {
439                 next unless $oldpagemtime{$page};
440                 my $line="mtime=$oldpagemtime{$page} ".
441                         "ctime=$pagectime{$page} ".
442                         "src=$pagesources{$page} ".
443                         "dest=$renderedfiles{$page}";
444                 $line.=" link=$_" foreach @{$links{$page}};
445                 if (exists $depends{$page}) {
446                         $line.=" depends=".encode_entities($depends{$page}, " \t\n");
447                 }
448                 print OUT $line."\n";
449         }
450         close OUT;
451 } #}}}
453 sub template_params (@) { #{{{
454         my $filename=shift;
455         
456         require HTML::Template;
457         return filter => sub {
458                         my $text_ref = shift;
459                         $$text_ref=&Encode::decode_utf8($$text_ref);
460                 },
461                 filename => "$config{templatedir}/$filename",
462                 loop_context_vars => 1,
463                 die_on_bad_params => 0,
464                 @_;
465 } #}}}
467 sub template ($;@) { #{{{
468         HTML::Template->new(template_params(@_));
469 } #}}}
471 sub misctemplate ($$) { #{{{
472         my $title=shift;
473         my $pagebody=shift;
474         
475         my $template=template("misc.tmpl");
476         $template->param(
477                 title => $title,
478                 indexlink => indexlink(),
479                 wikiname => $config{wikiname},
480                 pagebody => $pagebody,
481                 baseurl => baseurl(),
482         );
483         return $template->output;
484 }#}}}
486 sub hook (@) { # {{{
487         my %param=@_;
488         
489         if (! exists $param{type} || ! ref $param{call} || ! exists $param{id}) {
490                 error "hook requires type, call, and id parameters";
491         }
492         
493         $hooks{$param{type}}{$param{id}}=\%param;
494 } # }}}
496 sub run_hooks ($$) { # {{{
497         # Calls the given sub for each hook of the given type,
498         # passing it the hook function to call.
499         my $type=shift;
500         my $sub=shift;
502         if (exists $hooks{$type}) {
503                 foreach my $id (keys %{$hooks{$type}}) {
504                         $sub->($hooks{$type}{$id}{call});
505                 }
506         }
507 } #}}}
509 sub globlist_to_pagespec ($) { #{{{
510         my @globlist=split(' ', shift);
512         my (@spec, @skip);
513         foreach my $glob (@globlist) {
514                 if ($glob=~/^!(.*)/) {
515                         push @skip, $glob;
516                 }
517                 else {
518                         push @spec, $glob;
519                 }
520         }
522         my $spec=join(" or ", @spec);
523         if (@skip) {
524                 my $skip=join(" and ", @skip);
525                 if (length $spec) {
526                         $spec="$skip and ($spec)";
527                 }
528                 else {
529                         $spec=$skip;
530                 }
531         }
532         return $spec;
533 } #}}}
535 sub is_globlist ($) { #{{{
536         my $s=shift;
537         $s=~/[^\s]+\s+([^\s]+)/ && $1 ne "and" && $1 ne "or";
538 } #}}}
540 sub safequote ($) { #{{{
541         my $s=shift;
542         $s=~s/[{}]//g;
543         return "q{$s}";
544 } #}}}
546 sub pagespec_merge ($$) { #{{{
547         my $a=shift;
548         my $b=shift;
550         return $a if $a eq $b;
552         # Support for old-style GlobLists.
553         if (is_globlist($a)) {
554                 $a=globlist_to_pagespec($a);
555         }
556         if (is_globlist($b)) {
557                 $b=globlist_to_pagespec($b);
558         }
560         return "($a) or ($b)";
561 } #}}}
563 sub pagespec_translate ($) { #{{{
564         # This assumes that $page is in scope in the function
565         # that evalulates the translated pagespec code.
566         my $spec=shift;
568         # Support for old-style GlobLists.
569         if (is_globlist($spec)) {
570                 $spec=globlist_to_pagespec($spec);
571         }
573         # Convert spec to perl code.
574         my $code="";
575         while ($spec=~m/\s*(\!|\(|\)|\w+\([^\)]+\)|[^\s()]+)\s*/ig) {
576                 my $word=$1;
577                 if (lc $word eq "and") {
578                         $code.=" &&";
579                 }
580                 elsif (lc $word eq "or") {
581                         $code.=" ||";
582                 }
583                 elsif ($word eq "(" || $word eq ")" || $word eq "!") {
584                         $code.=" ".$word;
585                 }
586                 elsif ($word =~ /^(link|backlink|created_before|created_after|creation_month|creation_year|creation_day)\((.+)\)$/) {
587                         $code.=" match_$1(\$page, ".safequote($2).")";
588                 }
589                 else {
590                         $code.=" match_glob(\$page, ".safequote($word).")";
591                 }
592         }
594         return $code;
595 } #}}}
597 sub pagespec_match ($$) { #{{{
598         my $page=shift;
599         my $spec=shift;
601         return eval pagespec_translate($spec);
602 } #}}}
604 sub match_glob ($$) { #{{{
605         my $page=shift;
606         my $glob=shift;
608         # turn glob into safe regexp
609         $glob=quotemeta($glob);
610         $glob=~s/\\\*/.*/g;
611         $glob=~s/\\\?/./g;
613         return $page=~/^$glob$/i;
614 } #}}}
616 sub match_link ($$) { #{{{
617         my $page=shift;
618         my $link=lc(shift);
620         my $links = $links{$page} or return undef;
621         foreach my $p (@$links) {
622                 return 1 if lc $p eq $link;
623         }
624         return 0;
625 } #}}}
627 sub match_backlink ($$) { #{{{
628         match_link(pop, pop);
629 } #}}}
631 sub match_created_before ($$) { #{{{
632         my $page=shift;
633         my $testpage=shift;
635         if (exists $pagectime{$testpage}) {
636                 return $pagectime{$page} < $pagectime{$testpage};
637         }
638         else {
639                 return 0;
640         }
641 } #}}}
643 sub match_created_after ($$) { #{{{
644         my $page=shift;
645         my $testpage=shift;
647         if (exists $pagectime{$testpage}) {
648                 return $pagectime{$page} > $pagectime{$testpage};
649         }
650         else {
651                 return 0;
652         }
653 } #}}}
655 sub match_creation_day ($$) { #{{{
656         return ((gmtime($pagectime{shift()}))[3] == shift);
657 } #}}}
659 sub match_creation_month ($$) { #{{{
660         return ((gmtime($pagectime{shift()}))[4] + 1 == shift);
661 } #}}}
663 sub match_creation_year ($$) { #{{{
664         return ((gmtime($pagectime{shift()}))[5] + 1900 == shift);
665 } #}}}