-
Notifications
You must be signed in to change notification settings - Fork 13
/
wiki.pl
executable file
·3991 lines (3737 loc) · 153 KB
/
wiki.pl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#! /usr/bin/perl
# Copyright (C) 2001-2015
# Alex Schroeder <alex@gnu.org>
# Copyright (C) 2014-2015
# Alex Jakimenko <alex.jakimenko@gmail.com>
# Copyleft 2008 Brian Curry <http://www.raiazome.com>
# ... including lots of patches from the UseModWiki site
# Copyright (C) 2001, 2002 various authors
# ... which was based on UseModWiki version 0.92 (April 21, 2001)
# Copyright (C) 2000, 2001 Clifford A. Adams
# <caadams@frontiernet.net> or <usemod@usemod.com>
# ... which was based on the GPLed AtisWiki 0.3
# Copyright (C) 1998 Markus Denker <marcus@ira.uka.de>
# ... which was based on the LGPLed CVWiki CVS-patches
# Copyright (C) 1997 Peter Merel
# ... and The Original WikiWikiWeb
# Copyright (C) 1996, 1997 Ward Cunningham <ward@c2.com>
# (code reused with permission)
# This program is free software: you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation, either version 3 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>.
package OddMuse;
use strict;
use utf8; # in case anybody ever addes UTF8 characters to the source
use CGI qw/-utf8/;
use CGI::Carp qw(fatalsToBrowser);
use File::Glob ':glob';
local $| = 1; # Do not buffer output (localized for mod_perl)
# Options:
our ($RssLicense, $RssCacheHours, @RcDays, $TempDir, $LockDir, $DataDir, $KeepDir, $PageDir, $RcOldFile, $IndexFile,
$BannedContent, $NoEditFile, $BannedHosts, $ConfigFile, $FullUrl, $SiteName, $HomePage, $LogoUrl, $RcDefault, $RssDir,
$IndentLimit, $RecentTop, $RecentLink, $EditAllowed, $UseDiff, $KeepDays, $KeepMajor, $EmbedWiki, $BracketText, $UseConfig,
$AdminPass, $EditPass, $PassHashFunction, $PassSalt, $NetworkFile, $BracketWiki, $FreeLinks, $WikiLinks, $SummaryHours,
$FreeLinkPattern, $RCName, $RunCGI, $ShowEdits, $LinkPattern, $RssExclude, $InterLinkPattern, $MaxPost, $UseGrep, $UrlPattern,
$UrlProtocols, $ImageExtensions, $InterSitePattern, $FS, $CookieName, $SiteBase, $StyleSheet, $NotFoundPg, $FooterNote, $NewText,
$EditNote, $UserGotoBar, $VisitorFile, $RcFile, %Smilies, %SpecialDays, $InterWikiMoniker, $SiteDescription, $RssImageUrl,
$ReadMe, $RssRights, $BannedCanRead, $SurgeProtection, $TopLinkBar, $TopSearchForm, $MatchingPages, $LanguageLimit,
$SurgeProtectionTime, $SurgeProtectionViews, $DeletedPage, %Languages, $InterMap, $ValidatorLink, %LockOnCreation,
$RssStyleSheet, %CookieParameters, @UserGotoBarPages, $NewComment, $HtmlHeaders, $StyleSheetPage, $ConfigPage, $ScriptName,
$CommentsPrefix, $CommentsPattern, @UploadTypes, $AllNetworkFiles, $UsePathInfo, $UploadAllowed, $LastUpdate, $PageCluster,
%PlainTextPages, $RssInterwikiTranslate, $UseCache, $Counter, $ModuleDir, $FullUrlPattern, $SummaryDefaultLength,
$FreeInterLinkPattern, %InvisibleCookieParameters, %AdminPages, $UseQuestionmark, $JournalLimit, $LockExpiration, $RssStrip,
%LockExpires, @IndexOptions, @Debugging, $DocumentHeader, %HtmlEnvironmentContainers, @MyAdminCode, @MyFooters,
@MyInitVariables, @MyMacros, @MyMaintenance, @MyRules);
# Internal variables:
our (%Page, %InterSite, %IndexHash, %Translate, %OldCookie, $FootnoteNumber, $OpenPageName, @IndexList, $Message, $q, $Now,
%RecentVisitors, @HtmlStack, @HtmlAttrStack, %MyInc, $CollectingJournal, $bol, $WikiDescription, $PrintedHeader,
%Locks, $Fragment, @Blocks, @Flags, $Today, @KnownLocks, $ModulesDescription, %Action, %RuleOrder, %Includes,
%RssInterwikiTranslate);
# Can be set outside the script: $DataDir, $UseConfig, $ConfigFile, $ModuleDir,
# $ConfigPage, $AdminPass, $EditPass, $ScriptName, $FullUrl, $RunCGI.
# 1 = load config file in the data directory
$UseConfig //= 1;
# Main wiki directory
$DataDir = $ENV{WikiDataDir} if $UseConfig and not $DataDir;
$DataDir ||= '/tmp/oddmuse'; # FIXME: /var/opt/oddmuse/wiki ?
$ConfigPage ||= ''; # config page
# 1 = Run script as CGI instead of loading as module
$RunCGI //= 1;
# 1 = allow page views using wiki.pl/PageName
$UsePathInfo = 1;
# -1 = disabled, 0 = 10s; 1 = partial HTML cache; 2 = HTTP/1.1 caching
$UseCache = 2;
$SiteName = 'Wiki'; # Name of site (used for titles)
$HomePage = 'HomePage'; # Home page
$CookieName = 'Wiki'; # Name for this wiki (for multi-wiki sites)
$SiteBase = ''; # Full URL for <BASE> header
$MaxPost = 1024 * 210; # Maximum 210K posts (about 200K for pages)
$StyleSheet = ''; # URL for CSS stylesheet (like '/wiki.css')
$StyleSheetPage = ''; # Page for CSS sheet
$LogoUrl = ''; # URL for site logo ('' for no logo)
$NotFoundPg = ''; # Page for not-found links ('' for blank pg)
$NewText = T('This page is empty.') . "\n"; # New page text
$NewComment = T('Add your comment here:'); # New comment text
$EditAllowed = 1; # 0 = no, 1 = yes, 2 = comments pages only, 3 = comments only
$AdminPass //= ''; # Whitespace separated passwords.
$EditPass //= ''; # Whitespace separated passwords.
$PassHashFunction //= ''; # Name of the function to create hashes
$PassSalt //= ''; # Salt will be added to any password before hashing
$BannedHosts = 'BannedHosts'; # Page for banned hosts
$BannedCanRead = 1; # 1 = banned cannot edit, 0 = banned cannot read
$BannedContent = 'BannedContent'; # Page for banned content (usually for link-ban)
$WikiLinks = 1; # 1 = LinkPattern is a link
$FreeLinks = 1; # 1 = [[some text]] is a link
$UseQuestionmark = 1; # 1 = append questionmark to links to nonexisting pages
$BracketText = 1; # 1 = [URL desc] uses a description for the URL
$BracketWiki = 1; # 1 = [WikiLink desc] uses a desc for the local link
$NetworkFile = 1; # 1 = file: is a valid protocol for URLs
$AllNetworkFiles = 0; # 1 = file:///foo is allowed -- the default allows only file://foo
$InterMap = 'InterMap'; # name of the intermap page, '' = disable
$RssInterwikiTranslate = 'RssInterwikiTranslate'; # name of RSS interwiki translation page, '' = disable
$ENV{PATH} = '/bin:/usr/bin'; # Path used to find 'diff' and 'grep'
$UseDiff = 1; # 1 = use diff
$UseGrep = 1; # 1 = use grep to speed up searches
$SurgeProtection = 1; # 1 = protect against leeches
$SurgeProtectionTime = 20; # Size of the protected window in seconds
$SurgeProtectionViews = 20; # How many page views to allow in this window
$DeletedPage = 'DeletedPage'; # Pages starting with this can be deleted
$RCName = 'RecentChanges'; # Name of changes page
@RcDays = qw(1 3 7 30 90); # Days for links on RecentChanges
$RcDefault = 30; # Default number of RecentChanges days
$KeepDays = 14; # Days to keep old revisions
$KeepMajor = 1; # 1 = keep at least one major rev when expiring pages
$SummaryHours = 4; # Hours to offer the old subject when editing a page
$SummaryDefaultLength = 150; # Length of default text for summary (0 to disable)
$ShowEdits = 0; # 1 = major and show minor edits in recent changes
$RecentTop = 1; # 1 = most recent entries at the top of the list
$RecentLink = 1; # 1 = link to usernames
$PageCluster = ''; # name of cluster page, eg. 'Cluster' to enable
$InterWikiMoniker = ''; # InterWiki prefix for this wiki for RSS
$SiteDescription = ''; # RSS Description of this wiki
$RssStrip = '^\d\d\d\d-\d\d-\d\d_'; # Regexp to strip from feed item titles
$RssImageUrl = $LogoUrl; # URL to image to associate with your RSS feed
$RssRights = ''; # Copyright notice for RSS, usually an URL to the appropriate text
$RssExclude = 'RssExclude'; # name of the page that lists pages to be excluded from the feed
$RssCacheHours = 1; # How many hours to cache remote RSS files
$RssStyleSheet = ''; # External style sheet for RSS files
$UploadAllowed = 0; # 1 = yes, 0 = administrators only
@UploadTypes = ('image/jpeg', 'image/png'); # MIME types allowed, all allowed if empty list
$EmbedWiki = 0; # 1 = no headers/footers
$FooterNote = ''; # HTML for bottom of every page
$EditNote = ''; # HTML notice above buttons on edit page
$TopLinkBar = 1; # 0 = goto bar both at the top and bottom; 1 = top, 2 = bottom
$TopSearchForm = 1; # 0 = search form both at the top and bottom; 1 = top, 2 = bottom
$MatchingPages = 0; # 1 = search page content and page titles
@UserGotoBarPages = (); # List of pagenames
$UserGotoBar = ''; # HTML added to end of goto bar
$ValidatorLink = 0; # 1 = Link to the W3C HTML validator service
$CommentsPrefix = ''; # prefix for comment pages, eg. 'Comments_on_' to enable
$CommentsPattern = undef; # regex used to match comment pages
$HtmlHeaders = ''; # Additional stuff to put in the HTML <head> section
$IndentLimit = 20; # Maximum depth of nested lists
$LanguageLimit = 3; # Number of matches req. for each language
$JournalLimit = 200; # how many pages can be collected in one go?
$DocumentHeader = qq(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN")
. qq( "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">\n)
. qq(<html xmlns="http://www.w3.org/1999/xhtml">);
# Checkboxes at the end of the index.
@IndexOptions = ();
# Display short comments below the GotoBar for special days
# Example: %SpecialDays = ('1-1' => 'New Year', '1-2' => 'Next Day');
%SpecialDays = ();
# Replace regular expressions with inlined images
# Example: %Smilies = (":-?D(?=\\W)" => '/pics/grin.png');
%Smilies = ();
# Detect page languages when saving edits
# Example: %Languages = ('de' => '\b(der|die|das|und|oder)\b');
%Languages = ();
@KnownLocks = qw(main diff index merge visitors); # locks to remove
$LockExpiration = 60; # How long before expirable locks are expired
%LockExpires = (diff=>1, index=>1, merge=>1, visitors=>1); # locks to expire after some time
%CookieParameters = (username=>'', pwd=>'', homepage=>'', theme=>'', css=>'', msg=>'', lang=>'', embed=>$EmbedWiki,
toplinkbar=>$TopLinkBar, topsearchform=>$TopSearchForm, matchingpages=>$MatchingPages, );
%InvisibleCookieParameters = (msg=>1, pwd=>1,);
%Action = (rc => \&BrowseRc, rollback => \&DoRollback,
browse => \&BrowseResolvedPage, maintain => \&DoMaintain,
random => \&DoRandom, pagelock => \&DoPageLock,
history => \&DoHistory, editlock => \&DoEditLock,
edit => \&DoEdit, version => \&DoShowVersion,
download => \&DoDownload, rss => \&DoRss,
unlock => \&DoUnlock, password => \&DoPassword,
index => \&DoIndex, admin => \&DoAdminPage,
clear => \&DoClearCache, debug => \&DoDebug,
contrib => \&DoContributors, more => \&DoJournal);
@MyRules = (\&LinkRules, \&ListRule); # don't set this variable, add to it!
%RuleOrder = (\&LinkRules => 0, \&ListRule => 0);
# The 'main' program, called at the end of this script file (aka. as handler)
sub DoWikiRequest {
Init();
DoSurgeProtection();
if (not $BannedCanRead and UserIsBanned() and not UserIsEditor()) {
ReportError(T('Reading not allowed: user, ip, or network is blocked.'), '403 FORBIDDEN',
0, $q->p(ScriptLink('action=password', T('Login'), 'password')));
}
DoBrowseRequest();
}
sub ReportError { # fatal!
my ($errmsg, $status, $log, @html) = @_;
InitRequest(); # make sure we can report errors before InitRequest
print GetHttpHeader('text/html', 'nocache', $status), GetHtmlHeader(T('Error')),
$q->start_div({class=>"error"}), $q->h1(QuoteHtml($errmsg)), @html, $q->end_div,
$q->end_html, "\n\n"; # newlines for FCGI because of exit()
WriteStringToFile("$TempDir/error", '<body>' . $q->h1("$status $errmsg") . $q->Dump) if $log;
map { ReleaseLockDir($_); } keys %Locks;
exit 2;
}
sub Init {
binmode(STDOUT, ':utf8'); # this is where the HTML gets printed
binmode(STDERR, ':utf8'); # just in case somebody prints debug info to stderr
InitDirConfig();
$FS = "\x1e"; # The FS character is the RECORD SEPARATOR control char in ASCII
$Message = ''; # Warnings and non-fatal errors.
InitLinkPatterns(); # Link pattern can be changed in config files
InitModules(); # Modules come first so that users can change module variables in config
InitConfig(); # Config comes as early as possible; remember $q is not available here
InitRequest(); # get $q with $MaxPost; set these in the config file
InitCookie(); # After InitRequest, because $q is used
InitVariables(); # After config, to change variables, after InitCookie for GetParam
}
sub InitModules {
if ($UseConfig and $ModuleDir and -d $ModuleDir) {
foreach my $lib (bsd_glob("$ModuleDir/*.p[ml]")) {
do $lib unless $MyInc{$lib};
$MyInc{$lib} = 1; # Cannot use %INC in mod_perl settings
$Message .= CGI::p("$lib: $@") if $@; # no $q exists, yet
}
}
}
sub InitConfig {
if ($UseConfig and $ConfigFile and not $INC{$ConfigFile} and -f $ConfigFile) {
do $ConfigFile; # these options must be set in a wrapper script or via the environment
$Message .= CGI::p("$ConfigFile: $@") if $@; # remember, no $q exists, yet
}
if ($ConfigPage) { # $FS and $MaxPost must be set in config file!
my ($status, $data) = ReadFile(GetPageFile(FreeToNormal($ConfigPage)));
my %data = ParseData($data); # before InitVariables so GetPageContent won't work
eval $data{text} if $data{text};
$Message .= CGI::p("$ConfigPage: $@") if $@;
}
}
sub InitDirConfig {
utf8::decode($DataDir); # just in case, eg. "WikiDataDir=/tmp/Zürich♥ perl wiki.pl"
$PageDir = "$DataDir/page"; # Stores page data
$KeepDir = "$DataDir/keep"; # Stores kept (old) page data
$TempDir = "$DataDir/temp"; # Temporary files and locks
$LockDir = "$TempDir/lock"; # DB is locked if this exists
$NoEditFile = "$DataDir/noedit"; # Indicates that the site is read-only
$RcFile = "$DataDir/rc.log"; # New RecentChanges logfile
$RcOldFile = "$DataDir/oldrc.log"; # Old RecentChanges logfile
$IndexFile = "$DataDir/pageidx"; # List of all pages
$VisitorFile = "$DataDir/visitors.log"; # List of recent visitors
$RssDir = "$DataDir/rss"; # For rss feed cache
$ReadMe = "$DataDir/README"; # file with default content for the HomePage
$ConfigFile ||= "$DataDir/config"; # Config file with Perl code to execute
$ModuleDir ||= "$DataDir/modules"; # For extensions (ending in .pm or .pl)
}
sub InitRequest { # set up $q
$CGI::POST_MAX = $MaxPost;
$q ||= new CGI;
}
sub InitVariables { # Init global session variables for mod_perl!
$WikiDescription = $q->p($q->a({-href=>'http://www.oddmuse.org/'}, 'Oddmuse'),
$Counter++ > 0 ? Ts('%s calls', $Counter) : '');
$WikiDescription .= $ModulesDescription if $ModulesDescription;
$PrintedHeader = 0; # Error messages don't print headers unless necessary
$ScriptName //= $q->url(); # URL used in links
$FullUrl ||= $ScriptName; # URL used in forms
%Locks = ();
@Blocks = ();
@Flags = ();
$Fragment = '';
%RecentVisitors = ();
$OpenPageName = ''; # Currently open page
my $add_space = $CommentsPrefix =~ /[ \t_]$/;
map { $$_ = FreeToNormal($$_); } # convert spaces to underscores on all configurable pagenames
(\$HomePage, \$RCName, \$BannedHosts, \$InterMap, \$StyleSheetPage, \$CommentsPrefix,
\$ConfigPage, \$NotFoundPg, \$RssInterwikiTranslate, \$BannedContent, \$RssExclude, );
$CommentsPrefix .= '_' if $add_space;
$CommentsPattern = "^$CommentsPrefix(.*)" unless defined $CommentsPattern or not $CommentsPrefix;
@UserGotoBarPages = ($HomePage, $RCName) unless @UserGotoBarPages;
my @pages = sort($BannedHosts, $StyleSheetPage, $ConfigPage, $InterMap,
$RssInterwikiTranslate, $BannedContent);
%AdminPages = map { $_ => 1} @pages, $RssExclude unless %AdminPages;
%LockOnCreation = map { $_ => 1} @pages unless %LockOnCreation;
%PlainTextPages = ($BannedHosts => 1, $BannedContent => 1,
$StyleSheetPage => 1, $ConfigPage => 1) unless %PlainTextPages;
delete $PlainTextPages{''}; # $ConfigPage and others might be empty.
CreateDir($DataDir); # Create directory if it doesn't exist
$Now = time; # Reset in case script is persistent
my $ts = (stat($IndexFile))[9]; # always stat for multiple server processes
ReInit() if not $ts or $LastUpdate != $ts; # reinit if another process changed files (requires $DataDir)
$LastUpdate = $ts;
unshift(@MyRules, \&MyRules) if defined(&MyRules) && (not @MyRules or $MyRules[0] != \&MyRules);
@MyRules = sort {$RuleOrder{$a} <=> $RuleOrder{$b}} @MyRules; # default is 0
ReportError(Ts('Cannot create %s', $DataDir) . ": $!", '500 INTERNAL SERVER ERROR') unless -d $DataDir;
@IndexOptions = (['pages', T('Include normal pages'), 1, \&AllPagesList]);
foreach my $sub (@MyInitVariables) {
my $result = &$sub;
$Message .= $q->p($@) if $@;
}
}
sub ReInit { # init everything we need if we want to link to stuff
my $id = shift; # when saving a page, what to do depends on the page being saved
AllPagesList() unless $id;
InterInit() if $InterMap and (not $id or $id eq $InterMap);
%RssInterwikiTranslate = () if not $id or $id eq $RssInterwikiTranslate; # special since rarely used
}
sub InitCookie {
undef $q->{'.cookies'}; # Clear cache if it exists (for SpeedyCGI)
my $cookie = $q->cookie($CookieName);
%OldCookie = split(/$FS/o, UrlDecode($cookie));
my %provided = map { $_ => 1 } $q->param;
for my $key (keys %OldCookie) {
SetParam($key, $OldCookie{$key}) unless $provided{$key};
}
CookieUsernameFix();
CookieRollbackFix();
}
sub CookieUsernameFix {
# Only valid usernames get stored in the new cookie.
my $name = GetParam('username', '');
$q->delete('username');
if (not $name) {
# do nothing
} elsif ($WikiLinks and not $FreeLinks and $name !~ /^$LinkPattern$/o) {
$Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
} elsif ($FreeLinks and $name !~ /^$FreeLinkPattern$/o) {
$Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
} elsif (length($name) > 50) { # Too long
$Message .= $q->p(T('UserName must be 50 characters or less: not saved'));
} else {
SetParam('username', $name);
}
}
sub CookieRollbackFix {
my @rollback = grep(/rollback-(\d+)/, $q->param);
if (@rollback and $rollback[0] =~ /(\d+)/) {
SetParam('to', $1);
$q->delete('action');
SetParam('action', 'rollback');
}
}
sub GetParam {
my ($name, $default) = @_;
utf8::encode($name); # turn to byte string
my $result = $q->param($name);
$result //= $default;
return QuoteHtml($result); # you need to unquote anything that can have <tags>
}
sub SetParam {
my ($name, $val) = @_;
$q->param($name, $val);
}
sub InitLinkPatterns {
my ($WikiWord, $QDelim);
$QDelim = '(?:"")?'; # Optional quote delimiter (removed from the output)
$WikiWord = '[A-Z]+[a-z\x{0080}-\x{fffd}]+[A-Z][A-Za-z\x{0080}-\x{fffd}]*'; # exclude noncharacters FFFE and FFFF
$LinkPattern = "($WikiWord)$QDelim";
$FreeLinkPattern = "([-,.()'%&?;<> _1-9A-Za-z\x{0080}-\x{fffd}]|[-,.()'%&?;<> _0-9A-Za-z\x{0080}-\x{fffd}][-,.()'%&?;<> _0-9A-Za-z\x{0080}-\x{fffd}]+)"; # disallow "0" and must match HTML and plain text (ie. > and >)
# Intersites must start with uppercase letter to avoid confusion with URLs.
$InterSitePattern = '[A-Z\x{0080}-\x{fffd}]+[A-Za-z\x{0080}-\x{fffd}]+';
$InterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,]*[-a-zA-Z0-9\x{0080}-\x{fffd}_=#\$\@~`\%&*+\\/])$QDelim";
$FreeInterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,()' ]+)"; # plus space and other characters, and no restrictions on the end of the pattern
$UrlProtocols = 'http|https|ftp|afs|news|nntp|mid|cid|mailto|wais|prospero|telnet|gopher|irc|feed';
$UrlProtocols .= '|file' if $NetworkFile;
my $UrlChars = '[-a-zA-Z0-9/@=+$_~*.,;:?!\'"()&#%]'; # see RFC 2396
my $EndChars = '[-a-zA-Z0-9/@=+$_~*]'; # no punctuation at the end of the url.
$UrlPattern = "((?:$UrlProtocols):$UrlChars+$EndChars)";
$FullUrlPattern="((?:$UrlProtocols):$UrlChars+)"; # when used in square brackets
$ImageExtensions = '(gif|jpg|jpeg|png|bmp|svg)';
}
sub Clean {
my $block = shift;
return 0 unless defined($block); # "0" must print
return 1 if $block eq ''; # '' is the result of a dirty rule
$Fragment .= $block;
return 1;
}
sub Dirty { # arg 1 is the raw text; the real output must be printed instead
if ($Fragment ne '') {
$Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end of ApplyRules)
print $Fragment;
push(@Blocks, $Fragment);
push(@Flags, 0);
}
push(@Blocks, shift);
push(@Flags, 1);
$Fragment = '';
}
sub ApplyRules {
# locallinks: apply rules that create links depending on local config (incl. interlink!)
my ($text, $locallinks, $withanchors, $revision, @tags) = @_; # $revision is used for images
$text =~ s/\r\n/\n/g; # DOS to Unix
$text =~ s/\n+$//g; # No trailing paragraphs
return if $text eq ''; # allow the text '0'
local $Fragment = ''; # the clean HTML fragment not yet on @Blocks
local @Blocks = (); # the list of cached HTML blocks
local @Flags = (); # a list for each block, 1 = dirty, 0 = clean
Clean(join('', map { AddHtmlEnvironment($_) } @tags));
if ($OpenPageName and $PlainTextPages{$OpenPageName}) { # there should be no $PlainTextPages{''}
Clean(CloseHtmlEnvironments() . $q->pre($text));
} elsif (my ($type) = TextIsFile($text)) { # TODO? $type defined here??
Clean(CloseHtmlEnvironments() . $q->p(T('This page contains an uploaded file:'))
. $q->p(GetDownloadLink($OpenPageName, (substr($type, 0, 6) eq 'image/'), $revision))
. (length $Page{summary} > 0 ? $q->blockquote(QuoteHtml($Page{summary})) : $q->p(T('No summary was provided for this file.'))));
} else {
my $smileyregex = join "|", keys %Smilies;
$smileyregex = qr/(?=$smileyregex)/;
local $_ = $text;
local $bol = 1;
while (1) {
# Block level elements should eat trailing empty lines to prevent empty p elements.
if ($bol and m/\G(\s*\n)+/cg) {
Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p'));
} elsif ($bol and m/\G(\<include(\s+(text|with-anchors))?\s+"(.*)"\>[ \t]*\n?)/cgi) {
# <include "uri..."> includes the text of the given URI verbatim
Clean(CloseHtmlEnvironments());
Dirty($1);
my ($oldpos, $old_, $type, $uri) = ((pos), $_, $3, UnquoteHtml($4)); # remember, page content is quoted!
if ($uri =~ /^($UrlProtocols):/o) {
if ($type eq 'text') {
print $q->pre({class=>"include $uri"}, QuoteHtml(GetRaw($uri)));
} else { # never use local links for remote pages, with a starting tag
print $q->start_div({class=>"include $uri"});
ApplyRules(QuoteHtml(GetRaw($uri)), 0, ($type eq 'with-anchors'), undef, 'p');
print $q->end_div();
}
} else {
$Includes{$OpenPageName} = 1;
local $OpenPageName = FreeToNormal($uri);
if ($type eq 'text') {
print $q->pre({class=>"include $OpenPageName"}, QuoteHtml(GetPageContent($OpenPageName)));
} elsif (not $Includes{$OpenPageName}) { # with a starting tag, watch out for recursion
print $q->start_div({class=>"include $OpenPageName"});
ApplyRules(QuoteHtml(GetPageContent($OpenPageName)), $locallinks, $withanchors, undef, 'p');
print $q->end_div();
delete $Includes{$OpenPageName};
} else {
print $q->p({-class=>'error'}, $q->strong(Ts('Recursive include of %s!', $OpenPageName)));
}
}
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
} elsif ($bol and m/\G(\<(journal|titles):?(\d*)((\s+|:)(\d*),?(\d*))?(\s+"(.*?)")?(\s+(reverse|past|future))?(\s+search\s+(.*))?\>[ \t]*\n?)/cgi) {
# <journal 10 "regexp"> includes 10 pages matching regexp
Clean(CloseHtmlEnvironments());
Dirty($1);
my ($oldpos, $old_) = (pos, $_); # remember these because of the call to PrintJournal()
PrintJournal($6, $7, $9, $11, $3, $13, $2);
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
} elsif ($bol and m/\G(\<rss(\s+(\d*))?\s+(.*?)\>[ \t]*\n?)/cgis) {
# <rss "uri..."> stores the parsed RSS of the given URI
Clean(CloseHtmlEnvironments());
Dirty($1);
my ($oldpos, $old_) = (pos, $_); # remember these because of the call to RSS()
print RSS($3 || 15, split(/\s+/, UnquoteHtml($4)));
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
} elsif (/\G(<search (.*?)>)/cgis) {
# <search regexp>
Clean(CloseHtmlEnvironments());
Dirty($1);
my ($oldpos, $old_) = (pos, $_);
print $q->start_div({-class=>'search'});
SearchTitleAndBody($2, \&PrintSearchResult, SearchRegexp($2));
print $q->end_div;
Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
} elsif ($bol and m/\G(<<<<<<< )/cg) {
my ($str, $count, $limit, $oldpos) = ($1, 0, 100, pos);
while (m/\G(.*\n)/cg and $count++ < $limit) {
$str .= $1;
last if (substr($1, 0, 29) eq '>>>>>>> ');
}
if ($count >= $limit) {
pos = $oldpos; # reset because we did not find a match
Clean('<<<<<<< ');
} else {
Clean(CloseHtmlEnvironments() . $q->pre({-class=>'conflict'}, $str) . AddHtmlEnvironment('p'));
}
} elsif ($bol and m/\G#REDIRECT/cg) {
Clean('#REDIRECT');
} elsif (%Smilies and m/\G$smileyregex/cog and Clean(SmileyReplace())) {
} elsif (Clean(RunMyRules($locallinks, $withanchors))) {
} elsif (m/\G\s*\n(\s*\n)+/cg) { # paragraphs: at least two newlines
Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p')); # another one like this further up
} elsif (m/\G&([A-Za-z]+|#[0-9]+|#x[A-Za-f0-9]+);/cg) { # entity references
Clean("&$1;");
} elsif (m/\G\s+/cg) {
Clean(' ');
} elsif (m/\G([A-Za-z\x{0080}-\x{fffd}]+([ \t]+[a-z\x{0080}-\x{fffd}]+)*[ \t]+)/cg
or m/\G([A-Za-z\x{0080}-\x{fffd}]+)/cg or m/\G(\S)/cg) {
Clean($1); # multiple words but do not match http://foo
} else {
last;
}
$bol = (substr($_, pos() - 1, 1) eq "\n");
}
}
pos = length $_; # notify module functions we've completed rule handling
Clean(CloseHtmlEnvironments()); # last block -- close it, cache it
if ($Fragment ne '') {
$Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end Dirty())
print $Fragment;
push(@Blocks, $Fragment);
push(@Flags, 0);
}
# this can be stored in the page cache -- see PrintCache
return (join($FS, @Blocks), join($FS, @Flags));
}
sub ListRule {
if ($bol && m/\G(\s*\n)*(\*+)[ \t]+/cg
or InElement('li') && m/\G(\s*\n)+(\*+)[ \t]+/cg) {
return CloseHtmlEnvironmentUntil('li')
. OpenHtmlEnvironment('ul', length($2)) . AddHtmlEnvironment('li');
}
return;
}
sub LinkRules {
my ($locallinks, $withanchors) = @_;
if ($locallinks
and ($BracketText && m/\G(\[$InterLinkPattern\s+([^\]]+?)\])/cog
or $BracketText && m/\G(\[\[$FreeInterLinkPattern\|([^\]]+?)\]\])/cog
or m/\G(\[$InterLinkPattern\])/cog or m/\G(\[\[\[$FreeInterLinkPattern\]\]\])/cog
or m/\G($InterLinkPattern)/cog or m/\G(\[\[$FreeInterLinkPattern\]\])/cog)) {
# [InterWiki:FooBar text] or [InterWiki:FooBar] or
# InterWiki:FooBar or [[InterWiki:foo bar|text]] or
# [[InterWiki:foo bar]] or [[[InterWiki:foo bar]]]-- Interlinks
# can change when the intermap changes (local config, therefore
# depend on $locallinks). The intermap is only read if
# necessary, so if this not an interlink, we have to backtrack a
# bit.
my $bracket = (substr($1, 0, 1) eq '[') # but \[\[$FreeInterLinkPattern\]\] it not bracket!
&& !((substr($1, 0, 2) eq '[[') && (substr($1, 2, 1) ne '[') && index($1, '|') < 0);
my $quote = (substr($1, 0, 2) eq '[[');
my ($oldmatch, $output) = ($1, GetInterLink($2, $3, $bracket, $quote)); # $3 may be empty
if ($oldmatch eq $output) { # no interlink
my ($site, $rest) = split(/:/, $oldmatch, 2);
Clean($site);
pos = (pos) - length($rest) - 1; # skip site, but reparse rest
} else {
Dirty($oldmatch);
print $output; # this is an interlink
}
} elsif ($BracketText && m/\G(\[$FullUrlPattern[|[:space:]]([^\]]+?)\])/cog
or $BracketText && m/\G(\[\[$FullUrlPattern[|[:space:]]([^\]]+?)\]\])/cog
or m/\G(\[$FullUrlPattern\])/cog or m/\G($UrlPattern)/cog) {
# [URL text] makes [text] link to URL, [URL] makes footnotes [1]
my ($str, $url, $text, $bracket, $rest) = ($1, $2, $3, (substr($1, 0, 1) eq '['), '');
if ($url =~ /(<|>|&)$/) { # remove trailing partial named entitites and add them as
$rest = $1; # back again at the end as trailing text.
$url =~ s/&(lt|gt|amp)$//;
}
if ($bracket and not defined $text) { # [URL] is dirty because the number may change
Dirty($str);
print GetUrl($url, $text, $bracket), $rest;
} else {
Clean(GetUrl($url, $text, $bracket, not $bracket) . $rest); # $text may be empty, no images in brackets
}
} elsif ($WikiLinks && m/\G!$LinkPattern/cog) {
Clean($1); # ! gets eaten
} elsif ($WikiLinks && $locallinks
&& ($BracketWiki && m/\G(\[$LinkPattern\s+([^\]]+?)\])/cog
or m/\G(\[$LinkPattern\])/cog or m/\G($LinkPattern)/cog)) {
# [LocalPage text], [LocalPage], LocalPage
Dirty($1);
my $bracket = (substr($1, 0, 1) eq '[' and not $3);
print GetPageOrEditLink($2, $3, $bracket);
} elsif ($locallinks && $FreeLinks && (m/\G(\[\[image:$FreeLinkPattern\]\])/cog
or m/\G(\[\[image:$FreeLinkPattern\|([^]|]+)\]\])/cog)) {
# [[image:Free Link]], [[image:Free Link|alt text]]
Dirty($1);
print GetDownloadLink(FreeToNormal($2), 1, undef, UnquoteHtml($3));
} elsif ($FreeLinks && $locallinks
&& ($BracketWiki && m/\G(\[\[$FreeLinkPattern\|([^\]]+)\]\])/cog
or m/\G(\[\[\[$FreeLinkPattern\]\]\])/cog
or m/\G(\[\[$FreeLinkPattern\]\])/cog)) {
# [[Free Link|text]], [[[Free Link]]], [[Free Link]]
Dirty($1);
my $bracket = (substr($1, 0, 3) eq '[[[');
print GetPageOrEditLink($2, $3, $bracket, 1); # $3 may be empty
} else {
return; # nothing matched
}
return ''; # one of the dirty rules matched (and they all are)
}
sub SetHtmlEnvironmentContainer {
my ($html_tag, $html_tag_attr) = @_;
$HtmlEnvironmentContainers{$html_tag} = defined $html_tag_attr ? (
$HtmlEnvironmentContainers{$html_tag} ? '|' . $HtmlEnvironmentContainers{$html_tag} : '')
. $html_tag_attr : '';
}
sub InElement { # is $html_tag in @HtmlStack?
my ($html_tag, $html_tag_attr) = @_;
my $i = 0;
foreach my $html_tag_current (@HtmlStack) {
return 1 if $html_tag_current eq $html_tag and
($html_tag_attr ? $HtmlAttrStack[$i] =~ m/$html_tag_attr/ : 1);
$i++;
} return '';
}
sub AddOrCloseHtmlEnvironment { # add $html_tag, if not already added; close, otherwise
my ($html_tag, $html_tag_attr) = @_;
return InElement ($html_tag, '^' . $html_tag_attr . '$')
? CloseHtmlEnvironment($html_tag, '^' . $html_tag_attr . '$')
: AddHtmlEnvironment ($html_tag, $html_tag_attr);
}
sub AddHtmlEnvironment { # add a new $html_tag
my ($html_tag, $html_tag_attr) = @_;
$html_tag_attr //= '';
if ($html_tag and not (@HtmlStack and $HtmlStack[0] eq $html_tag and
($html_tag_attr ? $HtmlAttrStack[0] =~ m/$html_tag_attr/ : 1))) {
unshift(@HtmlStack, $html_tag);
unshift(@HtmlAttrStack, $html_tag_attr);
return '<' . $html_tag . ($html_tag_attr ? ' ' . $html_tag_attr : '') . '>';
} return ''; # always return something
}
sub OpenHtmlEnvironment { # close the previous $html_tag and open a new one
my ($html_tag, $depth, $html_tag_attr, $tag_regex) = @_;
my ($html, $found, @stack) = ('', 0); # always return something
while (@HtmlStack and $found < $depth) { # determine new stack
my $tag = pop(@HtmlStack);
$found++ if ($tag_regex ? $tag =~ $tag_regex : $tag eq $html_tag);
unshift(@stack, $tag);
}
unshift(@stack, pop(@HtmlStack)) if @HtmlStack and $found < $depth; # nested sublist coming up, keep list item
@HtmlStack = @stack unless $found; # if starting a new list
$html .= CloseHtmlEnvironments(); # close remaining elements (or all elements if a new list)
@HtmlStack = @stack if $found; # if not starting a new list
$depth = $IndentLimit if $depth > $IndentLimit; # requested depth 0 makes no sense
$html_tag_attr = qq/class="$html_tag_attr"/ # backwards-compatibility hack: classically, the third argument to this function was a single CSS class, rather than string of HTML tag attributes as in the second argument to the "AddHtmlEnvironment" function. To allow both sorts, we conditionally change this string to 'class="$html_tag_attr"' when this string is a single CSS class.
if $html_tag_attr and $html_tag_attr !~ m/^\s*[[:alpha:]]@@+\s*=\s*('|").+\1/;
splice(@HtmlAttrStack, 0, @HtmlAttrStack - @HtmlStack); # truncate to size of @HtmlStack
foreach ($found .. $depth - 1) {
unshift(@HtmlStack, $html_tag);
unshift(@HtmlAttrStack, $html_tag_attr);
$html .= $html_tag_attr ? "<$html_tag $html_tag_attr>" : "<$html_tag>";
}
return $html;
}
sub CloseHtmlEnvironments { # close all -- remember to use AddHtmlEnvironment('p') if required!
return CloseHtmlEnvironmentUntil() if pos($_) == length($_); # close all HTML environments if we're are at the end of this page
my $html = '';
while (@HtmlStack) {
defined $HtmlEnvironmentContainers{$HtmlStack[0]} and # avoid closing block level elements
($HtmlEnvironmentContainers{$HtmlStack[0]} ? $HtmlAttrStack[0] =~
m/$HtmlEnvironmentContainers{$HtmlStack[0]}/ : 1) and return $html;
shift(@HtmlAttrStack);
$html .= '</' . shift(@HtmlStack) . '>';
}
return $html;
}
sub CloseHtmlEnvironment { # close environments up to and including $html_tag
my $html = CloseHtmlEnvironmentUntil(@_) if @_ and InElement(@_);
if (@HtmlStack and (not(@_) or defined $html)) {
shift(@HtmlAttrStack);
return $html . '</' . shift(@HtmlStack) . '>';
}
return $html || ''; # avoid returning undefined
}
sub CloseHtmlEnvironmentUntil { # close environments up to but not including $html_tag
my ($html_tag, $html_tag_attr) = @_;
my $html = '';
while (@HtmlStack && (pos($_) == length($_) || # while there is an HTML tag-stack and we are at the end of this page or...
!($html_tag ? $HtmlStack[0] eq $html_tag && # the top tag is not the desired tag and...
($html_tag_attr ? $HtmlAttrStack[0] =~ # its attributes do not match,
m/$html_tag_attr/ : 1) : ''))) { # then...
shift(@HtmlAttrStack); # shift off the top tag and
$html .= '</' . shift(@HtmlStack) . '>'; # append it to our HTML string.
}
return $html;
}
sub SmileyReplace {
foreach my $regexp (keys %Smilies) {
if (m/\G($regexp)/cg) {
return $q->img({-src=>$Smilies{$regexp}, -alt=>UnquoteHtml($1), -class=>'smiley'});
}
}
}
sub RunMyRules {
my ($locallinks, $withanchors) = @_;
foreach my $sub (@MyRules) {
my $result = &$sub($locallinks, $withanchors);
SetParam('msg', $@) if $@;
return $result if defined($result);
}
return;
}
sub RunMyMacros {
$_ = shift;
foreach my $macro (@MyMacros) { &$macro };
return $_;
}
sub PrintWikiToHTML {
my ($markup, $is_saving_cache, $revision, $is_locked) = @_;
my ($blocks, $flags);
$FootnoteNumber = 0;
$markup =~ s/$FS//go if $markup; # Remove separators (paranoia)
$markup = QuoteHtml($markup);
($blocks, $flags) = ApplyRules($markup, 1, $is_saving_cache, $revision, 'p');
if ($is_saving_cache and not $revision and $Page{revision} # don't save revision 0 pages
and $Page{blocks} ne $blocks and $Page{flags} ne $flags) {
$Page{blocks} = $blocks;
$Page{flags} = $flags;
if ($is_locked or RequestLockDir('main')) { # not fatal!
SavePage();
ReleaseLock() unless $is_locked;
}
}
}
sub DoClearCache {
return unless UserIsAdminOrError();
RequestLockOrError();
print GetHeader('', T('Clear Cache')), $q->start_div({-class=>'content clear'}),
$q->p(T('Main lock obtained.')), '<p>';
foreach my $id (AllPagesList()) {
OpenPage($id);
delete @Page{qw(blocks flags languages)};
$Page{languages} = GetLanguages($Page{blocks}) unless TextIsFile($Page{blocks});
SavePage();
print $q->br(), GetPageLink($id);
}
print '</p>', $q->p(T('Main lock released.')), $q->end_div();
utime time, time, $IndexFile; # touch index file
ReleaseLock();
PrintFooter();
}
sub QuoteHtml {
my $html = shift;
$html =~ s/&/&/g;
$html =~ s/</</g;
$html =~ s/>/>/g;
$html =~ s/[\x00-\x08\x0b\x0c\x0e-\x1f]/ /g; # legal xml: #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
return $html;
}
sub UnquoteHtml {
my $html = shift;
$html =~ s/</</g;
$html =~ s/>/>/g;
$html =~ s/&/&/g;
$html =~ s/%26/&/g;
return $html;
}
sub UrlEncode {
my $str = shift;
return '' unless $str;
utf8::encode($str); # turn to byte string
my @letters = split(//, $str);
my %safe = map {$_ => 1} ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', '.', '!', '~', '*', "'", '(', ')', '#');
foreach my $letter (@letters) {
$letter = sprintf("%%%02x", ord($letter)) unless $safe{$letter};
}
return join('', @letters);
}
sub UrlDecode {
my $str = shift;
$str =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/ge;
utf8::decode($str); # make internal string
return $str;
}
sub QuoteRegexp {
my $re = shift;
$re =~ s/([\\\[\]\$()^.])/\\$1/g;
return $re;
}
sub GetRaw {
my $uri = shift;
return unless eval { require LWP::UserAgent; };
my $ua = LWP::UserAgent->new;
my $response = $ua->get($uri);
return $response->decoded_content if $response->is_success;
}
sub DoJournal {
print GetHeader(undef, T('Journal'));
print $q->start_div({-class=>'content'});
PrintJournal(map { GetParam($_, ''); } qw(num num regexp mode offset search variation));
print $q->end_div();
PrintFooter();
}
sub JournalSort { $b cmp $a }
sub PrintJournal {
return if $CollectingJournal; # avoid infinite loops
local $CollectingJournal = 1;
my ($num, $numMore, $regexp, $mode, $offset, $search, $variation) = @_;
$variation ||= 'journal';
$regexp ||= '^\d\d\d\d-\d\d-\d\d';
$num ||= 10;
$numMore = $num unless $numMore ne '';
$offset ||= 0;
# FIXME: Should pass filtered list of pages to SearchTitleAndBody to save time?
my @pages = sort JournalSort (grep(/$regexp/, $search ? SearchTitleAndBody($search) : AllPagesList()));
@pages = reverse @pages if $mode eq 'reverse' or $mode eq 'future';
$b = $Today // CalcDay($Now);
if ($mode eq 'future' || $mode eq 'past') {
my $compare = $mode eq 'future' ? -1 : 1;
for (my $i = 0; $i < @pages; $i++) {
$a = $pages[$i];
if (JournalSort() == $compare) {
@pages = @pages[$i .. $#pages];
last;
}
}
}
return unless $pages[$offset];
print $q->start_div({-class=>'journal'});
my $next = $offset + PrintAllPages(1, 1, $num, $variation, @pages[$offset .. $#pages]);
print $q->end_div();
$regexp = UrlEncode($regexp);
$search = UrlEncode($search);
if ($pages[$next] and $numMore != 0) {
print $q->p({-class=>'more'}, ScriptLink("action=more;num=$numMore;regexp=$regexp;search=$search;mode=$mode;offset=$next;variation=$variation", T('More...'), 'more'));
}
}
sub PrintAllPages {
my ($links, $comments, $num, $variation, @pages) = @_;
my $lang = GetParam('lang', 0);
my ($i, $n) = 0;
for my $id (@pages) {
last if $n >= $JournalLimit and not UserIsAdmin() or $num and $n >= $num;
$i++; # pages looked at
local ($OpenPageName, %Page); # this is local!
OpenPage($id);
my @languages = split(/,/, $Page{languages});
next if $lang and @languages and not grep(/$lang/, @languages);
next if PageMarkedForDeletion();
next if substr($Page{text}, 0, 10) eq '#REDIRECT ';
print $q->start_div({-class=>'page'}),
$q->h1($links ? GetPageLink($id)
: $q->a({-name=>$id}, UrlEncode(FreeToNormal($id))));
if ($variation ne 'titles') {
PrintPageHtml();
PrintPageCommentsLink($id, $comments);
}
print $q->end_div();
$n++; # pages actually printed
}
return $i;
}
sub PrintPageCommentsLink {
my ($id, $comments) = @_;
if ($comments and $CommentsPattern and $id !~ /$CommentsPattern/o) {
print $q->p({-class=>'comment'},
GetPageLink($CommentsPrefix . $id, T('Comments on this page')));
}
}
sub RSS {
return if $CollectingJournal; # avoid infinite loops when using full=1
local $CollectingJournal = 1;
my $maxitems = shift;
my @uris = @_;
my %lines;
if (not eval { require XML::RSS; }) {
my $err = $@;
return $q->div({-class=>'rss'}, $q->p({-class=>'error'}, $q->strong(T('XML::RSS is not available on this system.')), $err));
}
# All strings that are concatenated with strings returned by the RSS
# feed must be decoded. Without this decoding, 'diff' and 'history'
# translations will be double encoded when printing the result.
my $tDiff = T('diff');
my $tHistory = T('history');
my $wikins = 'http://purl.org/rss/1.0/modules/wiki/';
my $rdfns = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
@uris = map { s/^"?(.*?)"?$/$1/; $_; } @uris; # strip quotes of uris
my ($str, %data) = GetRss(@uris);
foreach my $uri (keys %data) {
my $data = $data{$uri};
if (not $data) {
$str .= $q->p({-class=>'error'}, $q->strong(Ts('%s returned no data, or LWP::UserAgent is not available.',
$q->a({-href=>$uri}, $uri))));
} else {
my $rss = new XML::RSS;
eval { local $SIG{__DIE__}; $rss->parse($data); };
if ($@) {
$str .= $q->p({-class=>'error'}, $q->strong(Ts('RSS parsing failed for %s', $q->a({-href=>$uri}, $uri)) . ': ' . $@));
} else {
my $interwiki;
if (@uris > 1) {
RssInterwikiTranslateInit(); # not needed anywhere else thus init only now and not in ReInit
$interwiki = $rss->{channel}->{$wikins}->{interwiki};
$interwiki =~ s/^\s+//; # when RDF is used, sometimes whitespace remains,
$interwiki =~ s/\s+$//; # which breaks the test for an existing $interwiki below
$interwiki ||= $rss->{channel}->{$rdfns}->{value};
$interwiki = $RssInterwikiTranslate{$interwiki} if $RssInterwikiTranslate{$interwiki};
$interwiki ||= $RssInterwikiTranslate{$uri};
}
my $num = 999;
$str .= $q->p({-class=>'error'}, $q->strong(Ts('No items found in %s.', $q->a({-href=>$uri}, $uri))))
unless @{$rss->{items}};
foreach my $i (@{$rss->{items}}) {
my $line;
my $date = $i->{dc}->{date};
if (not $date and $i->{pubDate}) {
$date = $i->{pubDate};
my %mon = (Jan=>1, Feb=>2, Mar=>3, Apr=>4, May=>5, Jun=>6,
Jul=>7, Aug=>8, Sep=>9, Oct=>10, Nov=>11, Dec=>12);
$date =~ s/^(?:[A-Z][a-z][a-z], )?(\d\d?) ([A-Z][a-z][a-z]) (\d\d(?:\d\d)?)/ # pubDate uses RFC 822
sprintf('%04d-%02d-%02d', ($3 < 100 ? 1900 + $3 : $3), $mon{$2}, $1)/e;
}
$date ||= sprintf("%03d", $num--); # for RSS 0.91 feeds without date, descending
my $title = $i->{title};
my $description = $i->{description};
if (not $title and $description) { # title may be missing in RSS 2.00
$title = $description;
$description = '';
}
$title = $i->{link} if not $title and $i->{link}; # if description and title are missing
$line .= ' (' . $q->a({-href=>$i->{$wikins}->{diff}}, $tDiff) . ')' if $i->{$wikins}->{diff};
$line .= ' (' . $q->a({-href=>$i->{$wikins}->{history}}, $tHistory) . ')' if $i->{$wikins}->{history};
if ($title) {
if ($i->{link}) {
$line .= ' ' . $q->a({-href=>$i->{link}, -title=>$date},
($interwiki ? $interwiki . ':' : '') . $title);
} else {
$line .= ' ' . $title;
}
}
my $contributor = $i->{dc}->{contributor};
$contributor ||= $i->{$wikins}->{username};
$contributor =~ s/^\s+//;
$contributor =~ s/\s+$//;
$contributor ||= $i->{$rdfns}->{value};
$line .= $q->span({-class=>'contributor'}, $q->span(T(' . . . . ')) . $contributor) if $contributor;
if ($description) {
if ($description =~ /</) {
$line .= $q->div({-class=>'description'}, $description);
} else {
$line .= $q->span({class=>'dash'}, ' – ') . $q->strong({-class=>'description'}, $description);
}
}
$date .= ' ' while ($lines{$date}); # make sure this is unique
$lines{$date} = $line;
}
}
}
}
my @lines = sort { $b cmp $a } keys %lines;
@lines = @lines[0 .. $maxitems-1] if $maxitems and $#lines > $maxitems;
my $date = '';
foreach my $key (@lines) {
my $line = $lines{$key};
if ($key =~ /(\d\d\d\d(?:-\d?\d)?(?:-\d?\d)?)(?:[T ](\d?\d:\d\d))?/) {
my ($day, $time) = ($1, $2);
if ($day ne $date) {
$str .= '</ul>' if $date; # close ul except for the first time where no open ul exists
$date = $day;
$str .= $q->p($q->strong($day)) . '<ul>';
}
$line = $q->span({-class=>'time'}, $time . ' UTC ') . $line if $time;
} elsif (not $date) {
$str .= '<ul>'; # if the feed doesn't have any dates we need to start the list anyhow
$date = $Now; # to ensure the list starts only once