wiki.pl 160 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156
  1. #! /usr/bin/env perl
  2. # Copyright (C) 2001-2020
  3. # Alex Schroeder <alex@gnu.org>
  4. # Copyright (C) 2014-2015
  5. # Alex Jakimenko <alex.jakimenko@gmail.com>
  6. # Copyleft 2008 Brian Curry <http://www.raiazome.com>
  7. # ... including lots of patches from the UseModWiki site
  8. # Copyright (C) 2001, 2002 various authors
  9. # ... which was based on UseModWiki version 0.92 (April 21, 2001)
  10. # Copyright (C) 2000, 2001 Clifford A. Adams
  11. # <caadams@frontiernet.net> or <usemod@usemod.com>
  12. # ... which was based on the GPLed AtisWiki 0.3
  13. # Copyright (C) 1998 Markus Denker <marcus@ira.uka.de>
  14. # ... which was based on the LGPLed CVWiki CVS-patches
  15. # Copyright (C) 1997 Peter Merel
  16. # ... and The Original WikiWikiWeb
  17. # Copyright (C) 1996, 1997 Ward Cunningham <ward@c2.com>
  18. # (code reused with permission)
  19. # This program is free software: you can redistribute it and/or modify it under
  20. # the terms of the GNU General Public License as published by the Free Software
  21. # Foundation, either version 3 of the License, or (at your option) any later
  22. # version.
  23. #
  24. # This program is distributed in the hope that it will be useful, but WITHOUT
  25. # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  26. # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  27. #
  28. # You should have received a copy of the GNU General Public License along with
  29. # this program. If not, see <http://www.gnu.org/licenses/>.
  30. package OddMuse;
  31. use strict;
  32. use warnings;
  33. no warnings 'numeric';
  34. no warnings 'uninitialized';
  35. use utf8; # in case anybody ever adds UTF8 characters to the source
  36. use B;
  37. use CGI qw/-utf8/;
  38. use CGI::Carp qw(fatalsToBrowser);
  39. use File::Glob ':glob';
  40. use Encode qw(encode_utf8 decode_utf8);
  41. use sigtrap 'handler' => \&HandleSignals, 'normal-signals', 'error-signals';
  42. local $| = 1; # Do not buffer output (localized for mod_perl)
  43. # Options:
  44. our ($ScriptName, $FullUrl, $PageDir, $TempDir, $LockDir, $KeepDir, $RssDir,
  45. $RcFile, $RcOldFile, $IndexFile, $NoEditFile, $VisitorFile, $DeleteFile, $RssLicense,
  46. $FreeLinkPattern, $LinkPattern, $FreeInterLinkPattern, $InterLinkPattern,
  47. $UrlPattern, $FullUrlPattern, $InterSitePattern,
  48. $UrlProtocols, $ImageExtensions, $LastUpdate,
  49. %LockOnCreation, %PlainTextPages, %AdminPages,
  50. @MyAdminCode, @MyFormChanges, @MyInitVariables, @MyMacros, @MyMaintenance,
  51. $DocumentHeader, %HtmlEnvironmentContainers, $FS, $Counter, @Debugging);
  52. # Internal variables:
  53. our ($q, $bol, $OpenPageName, %Page, %Translate, %IndexHash, @IndexList,
  54. @HtmlStack, @HtmlAttrStack, @Blocks, @Flags,
  55. %Includes, $FootnoteNumber, $CollectingJournal, $HeaderIsPrinted,
  56. %Locks, $Fragment, $Today, $ModulesDescription, %RssInterwikiTranslate,
  57. $Message, $Now, %RecentVisitors, %MyInc, $WikiDescription, %InterSite, %OldCookie);
  58. # Can be set outside the script: $DataDir, $UseConfig, $ConfigFile, $ModuleDir,
  59. # $ConfigPage, $AdminPass, $EditPass, $ScriptName, $FullUrl, $RunCGI.
  60. # 1 = load config file in the data directory
  61. our $UseConfig //= 1;
  62. # Main wiki directory
  63. our $DataDir;
  64. $DataDir ||= decode_utf8($ENV{WikiDataDir}) if $UseConfig;
  65. $DataDir ||= '/tmp/oddmuse'; # FIXME: /var/opt/oddmuse/wiki ?
  66. $DataDir = "./$DataDir" unless $DataDir =~ m!^(/|\./)!;
  67. our $ConfigFile;
  68. $ConfigFile ||= $ENV{WikiConfigFile} if $UseConfig;
  69. our $ModuleDir;
  70. $ModuleDir ||= $ENV{WikiModuleDir} if $UseConfig;
  71. our $ConfigPage ||= '';
  72. # 1 = Run script as CGI instead of loading as module
  73. our $RunCGI //= 1;
  74. # 1 = allow page views using wiki.pl/PageName
  75. our $UsePathInfo = 1;
  76. # -1 = disabled, 0 = 10s; 1 = partial HTML cache; 2 = HTTP/1.1 caching
  77. our $UseCache = 2;
  78. our $SiteName = 'Wiki'; # Name of site (used for titles)
  79. our $HomePage = 'HomePage'; # Home page
  80. our $CookieName = 'Wiki'; # Name for this wiki (for multi-wiki sites)
  81. our $MaxPost = 1024 * 210; # Maximum 210K posts (about 200K for pages)
  82. our $StyleSheet = ''; # URL for CSS stylesheet (like '/wiki.css')
  83. our $StyleSheetPage = ''; # Page for CSS sheet
  84. our $LogoUrl = ''; # URL for site logo ('' for no logo)
  85. our $NotFoundPg = ''; # Page for not-found links ('' for blank pg)
  86. our $EditAllowed = 1; # 0 = no, 1 = yes, 2 = comments pages only, 3 = comments only
  87. our $AdminPass //= ''; # Whitespace separated passwords.
  88. our $EditPass //= ''; # Whitespace separated passwords.
  89. our $PassHashFunction //= ''; # Name of the function to create hashes
  90. our $PassSalt //= ''; # Salt will be added to any password before hashing
  91. our $BannedHosts = 'BannedHosts'; # Page for banned hosts
  92. our $BannedCanRead = 1; # 1 = banned cannot edit, 0 = banned cannot read
  93. our $BannedContent = 'BannedContent'; # Page for banned content (usually for link-ban)
  94. our $WikiLinks = ''; # 1 = LinkPattern is a link
  95. our $FreeLinks = 1; # 1 = [[some text]] is a link
  96. our $UseQuestionmark = 1; # 1 = append questionmark to links to nonexisting pages
  97. our $BracketText = 1; # 1 = [URL desc] uses a description for the URL
  98. our $BracketWiki = 1; # 1 = [WikiLink desc] uses a desc for the local link
  99. our $NetworkFile = 1; # 1 = file: is a valid protocol for URLs
  100. our $AllNetworkFiles = 0; # 1 = file:///foo is allowed -- the default allows only file://foo
  101. our $InterMap = 'InterMap'; # name of the intermap page, '' = disable
  102. our $RssInterwikiTranslate = 'RssInterwikiTranslate'; # name of RSS interwiki translation page, '' = disable
  103. $ENV{PATH} = '/bin:/usr/bin'; # Path used to find 'diff' and 'grep'
  104. our $UseDiff = 1; # 1 = use diff
  105. our $SurgeProtection = 1; # 1 = protect against leeches
  106. our $SurgeProtectionTime = 20; # Size of the protected window in seconds
  107. our $SurgeProtectionViews = 20; # How many page views to allow in this window
  108. our $DeletedPage = 'DeletedPage'; # Pages starting with this can be deleted
  109. our $RCName = 'RecentChanges'; # Name of changes page
  110. our @RcDays = qw(1 3 7 30 90); # Days for links on RecentChanges
  111. our $RcDefault = 30; # Default number of RecentChanges days
  112. our $KeepHostDays = 4; # Days to keep IP numbers for
  113. our $KeepDays = 0; # Days to keep old revisions (0 means keep forever)
  114. our $KeepMajor = 1; # 1 = keep at least one major rev when expiring pages
  115. our $SummaryHours = 4; # Hours to offer the old subject when editing a page
  116. our $SummaryDefaultLength = 150; # Length of default text for summary (0 to disable)
  117. our $ShowEdits = 0; # 1 = major and show minor edits in recent changes
  118. our $ShowAll = 0; # 1 = show multiple edits per page in recent changes
  119. our $ShowRollbacks = 0; # 1 = show rollbacks in recent changes
  120. our $RecentLink = 1; # 1 = link to usernames
  121. our $PageCluster = ''; # name of cluster page, eg. 'Cluster' to enable
  122. our $InterWikiMoniker = ''; # InterWiki prefix for this wiki for RSS
  123. our $SiteDescription = ''; # RSS Description of this wiki
  124. our $RssStrip = '^\d\d\d\d-\d\d-\d\d_'; # Regexp to strip from feed item titles
  125. our $RssImageUrl = $LogoUrl; # URL to image to associate with your RSS feed
  126. our $RssRights = ''; # Copyright notice for RSS, usually an URL to the appropriate text
  127. our $RssExclude = 'RssExclude'; # name of the page that lists pages to be excluded from the feed
  128. our $RssCacheHours = 1; # How many hours to cache remote RSS files
  129. our $RssStyleSheet = ''; # External style sheet for RSS files
  130. our $UploadAllowed = 0; # 1 = yes, 0 = administrators only
  131. our @UploadTypes = ('image/jpeg', 'image/png'); # MIME types allowed, all allowed if empty list
  132. our $EmbedWiki = 0; # 1 = no headers/footers
  133. our $FooterNote = ''; # HTML for bottom of every page
  134. our $EditNote = ''; # HTML notice above buttons on edit page
  135. our $TopLinkBar = 1; # 0 = goto bar both at the top and bottom; 1 = top, 2 = bottom
  136. our $TopSearchForm = 1; # 0 = search form both at the top and bottom; 1 = top, 2 = bottom
  137. our $MatchingPages = 0; # 1 = search page content and page titles
  138. our @UserGotoBarPages = (); # List of pagenames
  139. our $UserGotoBar = ''; # HTML added to end of goto bar
  140. our $CommentsPrefix = ''; # prefix for comment pages, eg. 'Comments_on_' to enable
  141. our $CommentsPattern = undef; # regex used to match comment pages
  142. our $HtmlHeaders = ''; # Additional stuff to put in the HTML <head> section
  143. our $IndentLimit = 20; # Maximum depth of nested lists
  144. our $CurrentLanguage = 'en'; # Language of error messages etc
  145. our $LanguageLimit = 3; # Number of matches req. for each language
  146. our $JournalLimit = 200; # how many pages can be collected in one go?
  147. our $PageNameLimit = 120; # max length of page name in bytes
  148. $DocumentHeader = "<!DOCTYPE html>\n<html>";
  149. our @MyFooters = (\&GetCommentForm, \&WrapperEnd, \&DefaultFooter);
  150. # Checkboxes at the end of the index.
  151. our @IndexOptions = ();
  152. # Display short comments below the GotoBar for special days
  153. # Example: %SpecialDays = ('1-1' => 'New Year', '1-2' => 'Next Day');
  154. our %SpecialDays = ();
  155. # Replace regular expressions with inlined images
  156. # Example: %Smilies = (":-?D(?=\\W)" => '/pics/grin.png');
  157. our %Smilies = ();
  158. # Detect page languages when saving edits
  159. # Example: %Languages = ('de' => '\b(der|die|das|und|oder)\b');
  160. our %Languages = ();
  161. our @KnownLocks = qw(main diff index merge visitors); # locks to remove
  162. our $LockExpiration = 60; # How long before expirable locks are expired
  163. our %LockExpires = (diff=>1, index=>1, merge=>1, visitors=>1); # locks to expire after some time
  164. our %LockCleaners = (); # What to do if a job under a lock gets a signal like SIGINT. e.g. 'diff' => \&CleanDiff
  165. our %CookieParameters = (username=>'', pwd=>'', homepage=>'', theme=>'', css=>'', msg=>'', lang=>'', embed=>$EmbedWiki,
  166. toplinkbar=>$TopLinkBar, topsearchform=>$TopSearchForm, matchingpages=>$MatchingPages, );
  167. our %Action = (rc => \&BrowseRc, rollback => \&DoRollback,
  168. browse => \&BrowseResolvedPage, maintain => \&DoMaintain,
  169. random => \&DoRandom, pagelock => \&DoPageLock,
  170. history => \&DoHistory, editlock => \&DoEditLock,
  171. edit => \&DoEdit, version => \&DoShowVersion,
  172. download => \&DoDownload, rss => \&DoRss,
  173. unlock => \&DoUnlock, password => \&DoPassword,
  174. index => \&DoIndex, admin => \&DoAdminPage,
  175. clear => \&DoClearCache, debug => \&DoDebug,
  176. contrib => \&DoContributors, more => \&DoJournal);
  177. our @MyRules = (\&LinkRules, \&ListRule); # don't set this variable, add to it!
  178. our %RuleOrder = (\&LinkRules => 0, \&ListRule => 0);
  179. # The 'main' program, called at the end of this script file (aka. as handler)
  180. sub DoWikiRequest {
  181. Init();
  182. DoSurgeProtection();
  183. if (not $BannedCanRead and UserIsBanned() and not UserIsEditor()) {
  184. ReportError(T('Reading not allowed: user, ip, or network is blocked.'), '403 FORBIDDEN',
  185. 0, $q->p(ScriptLink('action=password', T('Login'), 'password')));
  186. }
  187. DoBrowseRequest();
  188. }
  189. sub ReportError { # fatal!
  190. my ($errmsg, $status, $log, @html) = @_;
  191. InitRequest(); # make sure we can report errors before InitRequest
  192. print GetHttpHeader('text/html', 'nocache', $status), GetHtmlHeader(T('Error')),
  193. $q->start_div({class=>'error'}), $q->h1(QuoteHtml($errmsg)), @html, $q->end_div,
  194. $q->end_html, "\n\n"; # newlines for FCGI because of exit()
  195. WriteStringToFile("$TempDir/error", '<body>' . $q->h1("$status $errmsg") . $q->Dump) if $log;
  196. map { ReleaseLockDir($_); } keys %Locks;
  197. exit 2;
  198. }
  199. sub Init {
  200. binmode(STDOUT, ':encoding(UTF-8)'); # this is where the HTML gets printed
  201. binmode(STDERR, ':encoding(UTF-8)'); # just in case somebody prints debug info to stderr
  202. InitDirConfig();
  203. $FS = "\x1e"; # The FS character is the RECORD SEPARATOR control char in ASCII
  204. $Message = ''; # Warnings and non-fatal errors.
  205. InitLinkPatterns(); # Link pattern can be changed in config files
  206. InitModules(); # Modules come first so that users can change module variables in config
  207. InitConfig(); # Config comes as early as possible; remember $q is not available here
  208. InitRequest(); # get $q with $MaxPost; set these in the config file
  209. InitCookie(); # After InitRequest, because $q is used
  210. InitVariables(); # After config, to change variables, after InitCookie for GetParam
  211. }
  212. sub InitModules {
  213. if ($UseConfig and $ModuleDir and IsDir($ModuleDir)) {
  214. foreach my $lib (Glob("$ModuleDir/*.p[ml]")) {
  215. if (not $MyInc{$lib}) {
  216. $MyInc{$lib} = 1; # Cannot use %INC in mod_perl settings
  217. my $file = encode_utf8($lib);
  218. do $file;
  219. $Message .= CGI::p("$lib: $@") if $@; # no $q exists, yet
  220. }
  221. }
  222. }
  223. }
  224. sub InitConfig {
  225. if ($UseConfig and $ConfigFile and not $INC{$ConfigFile} and IsFile($ConfigFile)) {
  226. do $ConfigFile; # these options must be set in a wrapper script or via the environment
  227. $Message .= CGI::p("$ConfigFile: $@") if $@; # remember, no $q exists, yet
  228. }
  229. if ($ConfigPage) { # $FS and $MaxPost must be set in config file!
  230. my ($status, $data) = ReadFile(GetPageFile(FreeToNormal($ConfigPage)));
  231. my $page = ParseData($data); # before InitVariables so GetPageContent won't work
  232. eval $page->{text} if $page->{text}; # perlcritic dislikes the use of eval here but we really mean it
  233. $Message .= CGI::p("$ConfigPage: $@") if $@;
  234. }
  235. }
  236. sub InitDirConfig {
  237. $PageDir = "$DataDir/page"; # Stores page data
  238. $KeepDir = "$DataDir/keep"; # Stores kept (old) page data
  239. $TempDir = "$DataDir/temp"; # Temporary files and locks
  240. $LockDir = "$TempDir/lock"; # DB is locked if this exists
  241. $NoEditFile = "$DataDir/noedit"; # Indicates that the site is read-only
  242. $RcFile = "$DataDir/rc.log"; # New RecentChanges logfile
  243. $RcOldFile = "$DataDir/oldrc.log"; # Old RecentChanges logfile
  244. $IndexFile = "$DataDir/pageidx"; # List of all pages
  245. $VisitorFile = "$DataDir/visitors.log"; # List of recent visitors
  246. $DeleteFile = "$DataDir/delete.log"; # Deletion logfile
  247. $RssDir = "$DataDir/rss"; # For rss feed cache
  248. $ConfigFile ||= "$DataDir/config"; # Config file with Perl code to execute
  249. $ModuleDir ||= "$DataDir/modules"; # For extensions (ending in .pm or .pl)
  250. }
  251. sub InitRequest { # set up $q
  252. $CGI::POST_MAX = $MaxPost;
  253. $q ||= new CGI;
  254. }
  255. sub InitVariables { # Init global session variables for mod_perl!
  256. $WikiDescription = $q->p($q->a({-href=>'https://www.oddmuse.org/'}, 'Oddmuse'),
  257. $Counter++ > 0 ? Ts('%s calls', $Counter) : '');
  258. $WikiDescription .= $ModulesDescription if $ModulesDescription;
  259. $HeaderIsPrinted = 0; # print HTTP headers only once
  260. $ScriptName //= $q->url(); # URL used in links
  261. $FullUrl ||= $ScriptName; # URL used in forms
  262. %Locks = ();
  263. @Blocks = ();
  264. @Flags = ();
  265. $Fragment = '';
  266. %RecentVisitors = ();
  267. $OpenPageName = ''; # Currently open page
  268. my $add_space = $CommentsPrefix =~ /[ \t_]$/;
  269. $$_ = FreeToNormal($$_) for # convert spaces to underscores on all configurable pagenames
  270. (\$HomePage, \$RCName, \$BannedHosts, \$InterMap, \$StyleSheetPage, \$CommentsPrefix,
  271. \$ConfigPage, \$NotFoundPg, \$RssInterwikiTranslate, \$BannedContent, \$RssExclude, );
  272. $CommentsPrefix .= '_' if $add_space;
  273. $CommentsPattern = "^$CommentsPrefix(.*)" unless defined $CommentsPattern or not $CommentsPrefix;
  274. @UserGotoBarPages = ($HomePage, $RCName) unless @UserGotoBarPages;
  275. my @pages = sort($BannedHosts, $StyleSheetPage, $ConfigPage, $InterMap,
  276. $RssInterwikiTranslate, $BannedContent);
  277. %AdminPages = map { $_ => 1} @pages, $RssExclude unless %AdminPages;
  278. %LockOnCreation = map { $_ => 1} @pages unless %LockOnCreation;
  279. %PlainTextPages = ($BannedHosts => 1, $BannedContent => 1,
  280. $StyleSheetPage => 1, $ConfigPage => 1) unless %PlainTextPages;
  281. delete $PlainTextPages{''}; # $ConfigPage and others might be empty.
  282. CreateDir($DataDir); # Create directory if it doesn't exist
  283. $Now = time; # Reset in case script is persistent
  284. my $ts = Modified($IndexFile); # always stat for multiple server processes
  285. ReInit() if not $ts or $LastUpdate != $ts; # reinit if another process changed files (requires $DataDir)
  286. $LastUpdate = $ts;
  287. unshift(@MyRules, \&MyRules) if defined(&MyRules) && (not @MyRules or $MyRules[0] != \&MyRules);
  288. @MyRules = sort {$RuleOrder{$a} <=> $RuleOrder{$b}} @MyRules; # default is 0
  289. ReportError(Ts('Cannot create %s', $DataDir) . ": $!", '500 INTERNAL SERVER ERROR') unless IsDir($DataDir);
  290. @IndexOptions = (['pages', T('Include normal pages'), 1, \&AllPagesList]);
  291. foreach my $sub (@MyInitVariables) {
  292. my $result = $sub->();
  293. $Message .= $q->p($@) if $@;
  294. }
  295. }
  296. sub ReInit { # init everything we need if we want to link to stuff
  297. my $id = shift; # when saving a page, what to do depends on the page being saved
  298. AllPagesList() unless $id;
  299. InterInit() if $InterMap and (not $id or $id eq $InterMap);
  300. %RssInterwikiTranslate = () if not $id or $id eq $RssInterwikiTranslate; # special since rarely used
  301. }
  302. sub InitCookie {
  303. undef $q->{'.cookies'}; # Clear cache if it exists (for SpeedyCGI)
  304. my $cookie = $q->cookie($CookieName);
  305. %OldCookie = split(/$FS/, UrlDecode($cookie));
  306. my %provided = map { $_ => 1 } $q->param;
  307. for my $key (keys %OldCookie) {
  308. SetParam($key, $OldCookie{$key}) unless $provided{$key};
  309. }
  310. CookieUsernameFix();
  311. CookieRollbackFix();
  312. }
  313. sub CookieUsernameFix {
  314. # Only valid usernames get stored in the new cookie.
  315. my $name = GetParam('username', '');
  316. $q->delete('username');
  317. if (not $name) {
  318. # do nothing
  319. } elsif ($WikiLinks and not $FreeLinks and $name !~ /^$LinkPattern$/) {
  320. $Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
  321. } elsif ($FreeLinks and $name !~ /^$FreeLinkPattern$/) {
  322. $Message .= $q->p(Ts('Invalid UserName %s: not saved.', $name));
  323. } elsif (length($name) > 50) { # Too long
  324. $Message .= $q->p(T('UserName must be 50 characters or less: not saved'));
  325. } else {
  326. SetParam('username', $name);
  327. }
  328. }
  329. sub CookieRollbackFix {
  330. my @rollback = grep(/rollback-(\d+)/, $q->param);
  331. if (@rollback and $rollback[0] =~ /(\d+)/) {
  332. SetParam('to', $1);
  333. $q->delete('action');
  334. SetParam('action', 'rollback');
  335. }
  336. }
  337. sub GetParam {
  338. my ($name, $default) = @_;
  339. my $result = $q->param(encode_utf8($name));
  340. $result //= $default;
  341. return QuoteHtml($result); # you need to unquote anything that can have <tags>
  342. }
  343. sub SetParam {
  344. my ($name, $val) = @_;
  345. $q->param($name, $val);
  346. }
  347. sub InitLinkPatterns {
  348. my ($WikiWord, $QDelim);
  349. $QDelim = '(?:"")?'; # Optional quote delimiter (removed from the output)
  350. $WikiWord = '\p{Uppercase}+\p{Lowercase}+\p{Uppercase}\p{Alphabetic}*';
  351. $LinkPattern = "($WikiWord)$QDelim";
  352. $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 &gt;)
  353. # Intersites must start with uppercase letter to avoid confusion with URLs.
  354. $InterSitePattern = '[A-Z\x{0080}-\x{fffd}]+[A-Za-z\x{0080}-\x{fffd}]+';
  355. $InterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,]*[-a-zA-Z0-9\x{0080}-\x{fffd}_=#\$\@~`\%&*+\\/])$QDelim";
  356. $FreeInterLinkPattern = "($InterSitePattern:[-a-zA-Z0-9\x{0080}-\x{fffd}_=!?#\$\@~`\%&*+\\/:;.,()' ]+)"; # plus space and other characters, and no restrictions on the end of the pattern
  357. $UrlProtocols = 'https?|ftp|afs|news|nntp|mid|cid|mailto|wais|prospero|telnet|gophers?|irc|feed';
  358. $UrlProtocols .= '|file' if $NetworkFile;
  359. my $UrlChars = '[-a-zA-Z0-9/@=+$_~*.,;:?!\'"()&#%]'; # see RFC 2396
  360. my $EndChars = '[-a-zA-Z0-9/@=+$_~*]'; # no punctuation at the end of the url.
  361. $UrlPattern = "((?:$UrlProtocols):$UrlChars+$EndChars)";
  362. $FullUrlPattern="((?:$UrlProtocols):$UrlChars+)"; # when used in square brackets
  363. $ImageExtensions = '(gif|jpg|jpeg|png|bmp|svg)';
  364. }
  365. sub Clean {
  366. my $block = shift;
  367. return 0 unless defined($block); # "0" must print
  368. return 1 if $block eq ''; # '' is the result of a dirty rule
  369. $Fragment .= $block;
  370. return 1;
  371. }
  372. sub Dirty { # arg 1 is the raw text; the real output must be printed instead
  373. if ($Fragment ne '') {
  374. $Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end of ApplyRules)
  375. print $Fragment;
  376. push(@Blocks, $Fragment);
  377. push(@Flags, 0);
  378. }
  379. push(@Blocks, shift);
  380. push(@Flags, 1);
  381. $Fragment = '';
  382. }
  383. sub ApplyRules {
  384. # locallinks: apply rules that create links depending on local config (incl. interlink!)
  385. my ($text, $locallinks, $withanchors, $revision, @tags) = @_; # $revision is used for images
  386. $text =~ s/\r\n/\n/g; # DOS to Unix
  387. $text =~ s/\n+$//g; # No trailing paragraphs
  388. return if $text eq ''; # allow the text '0'
  389. local $Fragment = ''; # the clean HTML fragment not yet on @Blocks
  390. local @Blocks = (); # the list of cached HTML blocks
  391. local @Flags = (); # a list for each block, 1 = dirty, 0 = clean
  392. Clean(join('', map { AddHtmlEnvironment($_) } @tags));
  393. if ($OpenPageName and $PlainTextPages{$OpenPageName}) { # there should be no $PlainTextPages{''}
  394. Clean(CloseHtmlEnvironments() . $q->pre($text));
  395. } elsif (my ($type) = TextIsFile($text)) { # TODO? $type defined here??
  396. Clean(CloseHtmlEnvironments() . $q->p(T('This page contains an uploaded file:'))
  397. . $q->p(GetDownloadLink($OpenPageName, (substr($type, 0, 6) eq 'image/'), $revision))
  398. . (length $Page{summary} > 0 ? $q->blockquote(QuoteHtml($Page{summary})) : $q->p(T('No summary was provided for this file.'))));
  399. } else {
  400. my $smileyregex = join "|", keys %Smilies;
  401. $smileyregex = qr/(?=$smileyregex)/;
  402. local $_ = $text;
  403. local $bol = 1;
  404. while (1) {
  405. # Block level elements should eat trailing empty lines to prevent empty p elements.
  406. if ($bol and m/\G(\s*\n)+/cg) {
  407. Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p'));
  408. } elsif ($bol and m/\G(\&lt;include(\s+(text|with-anchors))?\s+"(.*)"\&gt;[ \t]*\n?)/cgi) {
  409. # <include "uri..."> includes the text of the given URI verbatim
  410. Clean(CloseHtmlEnvironments());
  411. Dirty($1);
  412. my ($oldpos, $old_, $type, $uri) = ((pos), $_, $3, UnquoteHtml($4)); # remember, page content is quoted!
  413. if ($uri =~ /^($UrlProtocols):/) {
  414. if ($type eq 'text') {
  415. print $q->pre({class=>"include $uri"}, QuoteHtml(GetRaw($uri)));
  416. } else { # never use local links for remote pages, with a starting tag
  417. print $q->start_div({class=>'include'});
  418. ApplyRules(QuoteHtml(GetRaw($uri)), 0, ($type eq 'with-anchors'), undef, 'p');
  419. print $q->end_div();
  420. }
  421. } else {
  422. $Includes{$OpenPageName} = 1;
  423. local $OpenPageName = FreeToNormal($uri);
  424. if ($type eq 'text') {
  425. print $q->pre({class=>"include $OpenPageName"}, QuoteHtml(GetPageContent($OpenPageName)));
  426. } elsif (not $Includes{$OpenPageName}) { # with a starting tag, watch out for recursion
  427. print $q->start_div({class=>"include $OpenPageName"});
  428. ApplyRules(QuoteHtml(GetPageContent($OpenPageName)), $locallinks, $withanchors, undef, 'p');
  429. print $q->end_div();
  430. delete $Includes{$OpenPageName};
  431. } else {
  432. print $q->p({-class=>'error'}, $q->strong(Ts('Recursive include of %s!', $OpenPageName)));
  433. }
  434. }
  435. Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
  436. ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
  437. } elsif ($bol and m/\G(\&lt;(journal|titles):?(\d*)((\s+|:)(\d*),?(\d*))?(\s+"(.*?)")?(\s+(reverse|past|future))?(\s+search\s+(.*))?\&gt;[ \t]*\n?)/cgi) {
  438. # <journal 10 "regexp"> includes 10 pages matching regexp
  439. Clean(CloseHtmlEnvironments());
  440. Dirty($1);
  441. my ($oldpos, $old_) = (pos, $_); # remember these because of the call to PrintJournal()
  442. PrintJournal($6, $7, $9, $11, $3, $13, $2);
  443. Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
  444. ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
  445. } elsif ($bol and m/\G(\&lt;rss(\s+(\d*))?\s+(.*?)\&gt;[ \t]*\n?)/cgis) {
  446. # <rss "uri..."> stores the parsed RSS of the given URI
  447. Clean(CloseHtmlEnvironments());
  448. Dirty($1);
  449. my ($oldpos, $old_) = (pos, $_); # remember these because of the call to RSS()
  450. print RSS($3 || 15, split(/\s+/, UnquoteHtml($4)));
  451. Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
  452. ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
  453. } elsif (/\G(&lt;search (.*?)&gt;)/cgis) {
  454. # <search regexp>
  455. Clean(CloseHtmlEnvironments());
  456. Dirty($1);
  457. my ($oldpos, $old_) = (pos, $_);
  458. print $q->start_div({-class=>'search'});
  459. SearchTitleAndBody($2, \&PrintSearchResult, SearchRegexp($2));
  460. print $q->end_div;
  461. Clean(AddHtmlEnvironment('p')); # if dirty block is looked at later, this will disappear
  462. ($_, pos) = ($old_, $oldpos); # restore \G (assignment order matters!)
  463. } elsif ($bol and m/\G(&lt;&lt;&lt;&lt;&lt;&lt;&lt; )/cg) {
  464. my ($str, $count, $limit, $oldpos) = ($1, 0, 100, pos);
  465. while (m/\G(.*\n)/cg and $count++ < $limit) {
  466. $str .= $1;
  467. last if (substr($1, 0, 29) eq '&gt;&gt;&gt;&gt;&gt;&gt;&gt; ');
  468. }
  469. if ($count >= $limit) {
  470. pos = $oldpos; # reset because we did not find a match
  471. Clean('&lt;&lt;&lt;&lt;&lt;&lt;&lt; ');
  472. } else {
  473. Clean(CloseHtmlEnvironments() . $q->pre({-class=>'conflict'}, $str) . AddHtmlEnvironment('p'));
  474. }
  475. } elsif ($bol and m/\G#REDIRECT/cg) {
  476. Clean('#REDIRECT');
  477. } elsif (%Smilies and m/\G$smileyregex/cg and Clean(SmileyReplace())) {
  478. } elsif (Clean(RunMyRules($locallinks, $withanchors))) {
  479. } elsif (m/\G\s*\n(\s*\n)+/cg) { # paragraphs: at least two newlines
  480. Clean(CloseHtmlEnvironments() . AddHtmlEnvironment('p')); # another one like this further up
  481. } elsif (m/\G&amp;([A-Za-z]+|#[0-9]+|#x[A-Za-f0-9]+);/cg) { # entity references
  482. Clean("&$1;");
  483. } elsif (m/\G\s+/cg) {
  484. Clean(' ');
  485. } elsif (m/\G([A-Za-z\x{0080}-\x{fffd}]+([ \t]+[a-z\x{0080}-\x{fffd}]+)*[ \t]+)/cg
  486. or m/\G([A-Za-z\x{0080}-\x{fffd}]+)/cg or m/\G(\S)/cg) {
  487. Clean($1); # multiple words but do not match http://foo
  488. } else {
  489. last;
  490. }
  491. $bol = (substr($_, pos() - 1, 1) eq "\n");
  492. }
  493. }
  494. pos = length $_; # notify module functions we've completed rule handling
  495. Clean(CloseHtmlEnvironments()); # last block -- close it, cache it
  496. if ($Fragment ne '') {
  497. $Fragment =~ s|<p>\s*</p>||g; # clean up extra paragraphs (see end Dirty())
  498. print $Fragment;
  499. push(@Blocks, $Fragment);
  500. push(@Flags, 0);
  501. }
  502. # this can be stored in the page cache -- see PrintCache
  503. return (join($FS, @Blocks), join($FS, @Flags));
  504. }
  505. sub ListRule {
  506. if ($bol && m/\G(\s*\n)*(\*+)[ \t]+/cg
  507. or InElement('li') && m/\G(\s*\n)+(\*+)[ \t]+/cg) {
  508. return CloseHtmlEnvironmentUntil('li')
  509. . OpenHtmlEnvironment('ul', length($2)) . AddHtmlEnvironment('li');
  510. }
  511. return;
  512. }
  513. sub LinkRules {
  514. my ($locallinks, $withanchors) = @_;
  515. if ($locallinks
  516. and ($BracketText && m/\G(\[$InterLinkPattern\s+([^\]]+?)\])/cg
  517. or $BracketText && m/\G(\[\[$FreeInterLinkPattern\|([^\]]+?)\]\])/cg
  518. or m/\G(\[$InterLinkPattern\])/cg or m/\G(\[\[\[$FreeInterLinkPattern\]\]\])/cg
  519. or m/\G($InterLinkPattern)/cg or m/\G(\[\[$FreeInterLinkPattern\]\])/cg)) {
  520. # [InterWiki:FooBar text] or [InterWiki:FooBar] or
  521. # InterWiki:FooBar or [[InterWiki:foo bar|text]] or
  522. # [[InterWiki:foo bar]] or [[[InterWiki:foo bar]]]-- Interlinks
  523. # can change when the intermap changes (local config, therefore
  524. # depend on $locallinks). The intermap is only read if
  525. # necessary, so if this not an interlink, we have to backtrack a
  526. # bit.
  527. my $bracket = (substr($1, 0, 1) eq '[') # but \[\[$FreeInterLinkPattern\]\] it not bracket!
  528. && !((substr($1, 0, 2) eq '[[') && (substr($1, 2, 1) ne '[') && index($1, '|') < 0);
  529. my $quote = (substr($1, 0, 2) eq '[[');
  530. my ($oldmatch, $output) = ($1, GetInterLink($2, $3, $bracket, $quote)); # $3 may be empty
  531. if ($oldmatch eq $output) { # no interlink
  532. my ($site, $rest) = split(/:/, $oldmatch, 2);
  533. Clean($site);
  534. pos = (pos) - length($rest) - 1; # skip site, but reparse rest
  535. } else {
  536. Dirty($oldmatch);
  537. print $output; # this is an interlink
  538. }
  539. } elsif ($BracketText && m/\G(\[$FullUrlPattern[|[:space:]]([^\]]+?)\])/cg
  540. or $BracketText && m/\G(\[\[$FullUrlPattern[|[:space:]]([^\]]+?)\]\])/cg
  541. or m/\G(\[$FullUrlPattern\])/cg or m/\G($UrlPattern)/cg) {
  542. # [URL text] makes [text] link to URL, [URL] makes footnotes [1]
  543. my ($str, $url, $text, $bracket, $rest) = ($1, $2, $3, (substr($1, 0, 1) eq '['), '');
  544. if ($url =~ /(&lt|&gt|&amp)$/) { # remove trailing partial named entitites and add them as
  545. $rest = $1; # back again at the end as trailing text.
  546. $url =~ s/&(lt|gt|amp)$//;
  547. }
  548. if ($bracket and not defined $text) { # [URL] is dirty because the number may change
  549. Dirty($str);
  550. print GetUrl($url, $text, $bracket), $rest;
  551. } else {
  552. Clean(GetUrl($url, $text, $bracket, not $bracket) . $rest); # $text may be empty, no images in brackets
  553. }
  554. } elsif ($WikiLinks && m/\G!$LinkPattern/cg) {
  555. Clean($1); # ! gets eaten
  556. } elsif ($WikiLinks && $locallinks
  557. && ($BracketWiki && m/\G(\[$LinkPattern\s+([^\]]+?)\])/cg
  558. or m/\G(\[$LinkPattern\])/cg or m/\G($LinkPattern)/cg)) {
  559. # [LocalPage text], [LocalPage], LocalPage
  560. Dirty($1);
  561. my $bracket = (substr($1, 0, 1) eq '[' and not $3);
  562. print GetPageOrEditLink($2, $3, $bracket);
  563. } elsif ($locallinks && $FreeLinks && (m/\G(\[\[image:$FreeLinkPattern\]\])/cg
  564. or m/\G(\[\[image:$FreeLinkPattern\|([^]|]+)\]\])/cg)) {
  565. # [[image:Free Link]], [[image:Free Link|alt text]]
  566. Dirty($1);
  567. print GetDownloadLink(FreeToNormal($2), 1, undef, UnquoteHtml($3));
  568. } elsif ($FreeLinks && $locallinks
  569. && ($BracketWiki && m/\G(\[\[$FreeLinkPattern\|([^\]]+)\]\])/cg
  570. or m/\G(\[\[\[$FreeLinkPattern\]\]\])/cg
  571. or m/\G(\[\[$FreeLinkPattern\]\])/cg)) {
  572. # [[Free Link|text]], [[[Free Link]]], [[Free Link]]
  573. Dirty($1);
  574. my $bracket = (substr($1, 0, 3) eq '[[[');
  575. print GetPageOrEditLink($2, $3, $bracket, 1); # $3 may be empty
  576. } else {
  577. return; # nothing matched
  578. }
  579. return ''; # one of the dirty rules matched (and they all are)
  580. }
  581. sub SetHtmlEnvironmentContainer {
  582. my ($html_tag, $html_tag_attr) = @_;
  583. $HtmlEnvironmentContainers{$html_tag} = defined $html_tag_attr ? (
  584. $HtmlEnvironmentContainers{$html_tag} ? '|' . $HtmlEnvironmentContainers{$html_tag} : '')
  585. . $html_tag_attr : '';
  586. }
  587. sub InElement { # is $html_tag in @HtmlStack?
  588. my ($html_tag, $html_tag_attr) = @_;
  589. my $i = 0;
  590. foreach my $html_tag_current (@HtmlStack) {
  591. return 1 if $html_tag_current eq $html_tag and
  592. ($html_tag_attr ? $HtmlAttrStack[$i] =~ m/$html_tag_attr/ : 1);
  593. $i++;
  594. } return '';
  595. }
  596. sub AddOrCloseHtmlEnvironment { # add $html_tag, if not already added; close, otherwise
  597. my ($html_tag, $html_tag_attr) = @_;
  598. return InElement ($html_tag, '^' . $html_tag_attr . '$')
  599. ? CloseHtmlEnvironment($html_tag, '^' . $html_tag_attr . '$')
  600. : AddHtmlEnvironment ($html_tag, $html_tag_attr);
  601. }
  602. sub AddHtmlEnvironment { # add a new $html_tag
  603. my ($html_tag, $html_tag_attr) = @_;
  604. $html_tag_attr //= '';
  605. if ($html_tag and not (@HtmlStack and $HtmlStack[0] eq $html_tag and
  606. ($html_tag_attr ? $HtmlAttrStack[0] =~ m/$html_tag_attr/ : 1))) {
  607. unshift(@HtmlStack, $html_tag);
  608. unshift(@HtmlAttrStack, $html_tag_attr);
  609. return '<' . $html_tag . ($html_tag_attr ? ' ' . $html_tag_attr : '') . '>';
  610. } return ''; # always return something
  611. }
  612. sub OpenHtmlEnvironment { # close the previous $html_tag and open a new one
  613. my ($html_tag, $depth, $html_tag_attr, $tag_regex) = @_;
  614. my ($html, $found, @stack) = ('', 0); # always return something
  615. while (@HtmlStack and $found < $depth) { # determine new stack
  616. my $tag = pop(@HtmlStack);
  617. $found++ if ($tag_regex ? $tag =~ $tag_regex : $tag eq $html_tag);
  618. unshift(@stack, $tag);
  619. }
  620. unshift(@stack, pop(@HtmlStack)) if @HtmlStack and $found < $depth; # nested sublist coming up, keep list item
  621. @HtmlStack = @stack unless $found; # if starting a new list
  622. $html .= CloseHtmlEnvironments(); # close remaining elements (or all elements if a new list)
  623. @HtmlStack = @stack if $found; # if not starting a new list
  624. $depth = $IndentLimit if $depth > $IndentLimit; # requested depth 0 makes no sense
  625. $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.
  626. if $html_tag_attr and $html_tag_attr !~ m/=/;
  627. splice(@HtmlAttrStack, 0, @HtmlAttrStack - @HtmlStack); # truncate to size of @HtmlStack
  628. foreach ($found .. $depth - 1) {
  629. unshift(@HtmlStack, $html_tag);
  630. unshift(@HtmlAttrStack, $html_tag_attr);
  631. $html .= $html_tag_attr ? "<$html_tag $html_tag_attr>" : "<$html_tag>";
  632. }
  633. return $html;
  634. }
  635. sub CloseHtmlEnvironments { # close all -- remember to use AddHtmlEnvironment('p') if required!
  636. return CloseHtmlEnvironmentUntil() if pos($_) == length($_); # close all HTML environments if we're are at the end of this page
  637. my $html = '';
  638. while (@HtmlStack) {
  639. defined $HtmlEnvironmentContainers{$HtmlStack[0]} and # avoid closing block level elements
  640. ($HtmlEnvironmentContainers{$HtmlStack[0]} ? $HtmlAttrStack[0] =~
  641. m/$HtmlEnvironmentContainers{$HtmlStack[0]}/ : 1) and return $html;
  642. shift(@HtmlAttrStack);
  643. $html .= '</' . shift(@HtmlStack) . '>';
  644. }
  645. return $html;
  646. }
  647. sub CloseHtmlEnvironment { # close environments up to and including $html_tag
  648. my $html = (@_ and InElement(@_)) ? CloseHtmlEnvironmentUntil(@_) : undef;
  649. if (@HtmlStack and (not(@_) or defined $html)) {
  650. shift(@HtmlAttrStack);
  651. $html .= '</' . shift(@HtmlStack) . '>';
  652. }
  653. return $html || ''; # avoid returning undefined
  654. }
  655. sub CloseHtmlEnvironmentUntil { # close environments up to but not including $html_tag
  656. my ($html_tag, $html_tag_attr) = @_;
  657. my $html = '';
  658. while (@HtmlStack && (pos($_) == length($_) || # while there is an HTML tag-stack and we are at the end of this page or...
  659. !($html_tag ? $HtmlStack[0] eq $html_tag && # the top tag is not the desired tag and...
  660. ($html_tag_attr ? $HtmlAttrStack[0] =~ # its attributes do not match,
  661. m/$html_tag_attr/ : 1) : ''))) { # then...
  662. shift(@HtmlAttrStack); # shift off the top tag and
  663. $html .= '</' . shift(@HtmlStack) . '>'; # append it to our HTML string.
  664. }
  665. return $html;
  666. }
  667. sub SmileyReplace {
  668. foreach my $regexp (keys %Smilies) {
  669. if (m/\G($regexp)/cg) {
  670. return $q->img({-src=>$Smilies{$regexp}, -alt=>UnquoteHtml($1), -class=>'smiley'});
  671. }
  672. }
  673. }
  674. sub RunMyRules {
  675. my ($locallinks, $withanchors) = @_;
  676. foreach my $sub (@MyRules) {
  677. my $result = $sub->($locallinks, $withanchors);
  678. SetParam('msg', $@) if $@;
  679. return $result if defined($result);
  680. }
  681. return;
  682. }
  683. sub RunMyMacros {
  684. $_ = shift;
  685. foreach my $macro (@MyMacros) { $macro->() };
  686. return $_;
  687. }
  688. sub PrintWikiToHTML {
  689. my ($markup, $is_saving_cache, $revision, $is_locked) = @_;
  690. my ($blocks, $flags);
  691. $FootnoteNumber = 0;
  692. $markup =~ s/$FS//g if $markup; # Remove separators (paranoia)
  693. $markup = QuoteHtml($markup);
  694. ($blocks, $flags) = ApplyRules($markup, 1, $is_saving_cache, $revision, 'p');
  695. if ($is_saving_cache and not $revision and $Page{revision} # don't save revision 0 pages
  696. and $Page{blocks} ne $blocks and $Page{flags} ne $flags) {
  697. $Page{blocks} = $blocks;
  698. $Page{flags} = $flags;
  699. if ($is_locked or RequestLockDir('main')) { # not fatal!
  700. SavePage();
  701. ReleaseLock() unless $is_locked;
  702. }
  703. }
  704. }
  705. sub DoClearCache {
  706. return unless UserIsAdminOrError();
  707. RequestLockOrError();
  708. print GetHeader('', T('Clear Cache')), $q->start_div({-class=>'content clear'}),
  709. $q->p(T('Main lock obtained.')), '<p>';
  710. foreach my $id (AllPagesList()) {
  711. OpenPage($id);
  712. delete @Page{qw(blocks flags languages)};
  713. $Page{languages} = GetLanguages($Page{blocks}) unless TextIsFile($Page{blocks});
  714. SavePage();
  715. print $q->br(), GetPageLink($id);
  716. }
  717. print '</p>', $q->p(T('Main lock released.')), $q->end_div();
  718. utime time, time, $IndexFile; # touch index file
  719. ReleaseLock();
  720. PrintFooter();
  721. }
  722. sub QuoteHtml {
  723. my $html = shift;
  724. $html =~ s/&/&amp;/g;
  725. $html =~ s/</&lt;/g;
  726. $html =~ s/>/&gt;/g;
  727. $html =~ s/[\x00-\x08\x0b\x0c\x0e-\x1f]/ /g; # legal xml: #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
  728. return $html;
  729. }
  730. sub UnquoteHtml {
  731. my $html = shift;
  732. $html =~ s/&lt;/</g;
  733. $html =~ s/&gt;/>/g;
  734. $html =~ s/&amp;/&/g;
  735. $html =~ s/%26/&/g;
  736. return $html;
  737. }
  738. sub UrlEncode {
  739. my $str = shift;
  740. return '' unless $str;
  741. my @letters = split(//, encode_utf8($str));
  742. my %safe = map {$_ => 1} ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', '.', '!', '~', '*', "'", '(', ')', '#');
  743. foreach my $letter (@letters) {
  744. $letter = sprintf("%%%02x", ord($letter)) unless $safe{$letter};
  745. }
  746. return join('', @letters);
  747. }
  748. sub UrlDecode {
  749. my $str = shift;
  750. return decode_utf8($str) if $str =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/eig;
  751. return $str;
  752. }
  753. sub QuoteRegexp {
  754. my $re = shift;
  755. $re =~ s/([\\\[\]\$()^.])/\\$1/g;
  756. return $re;
  757. }
  758. sub GetRaw {
  759. my $uri = shift;
  760. return unless eval { require LWP::UserAgent; };
  761. my $ua = LWP::UserAgent->new;
  762. my $response = $ua->get($uri);
  763. return $response->decoded_content if $response->is_success;
  764. }
  765. sub DoJournal {
  766. print GetHeader(undef, T('Journal'));
  767. print $q->start_div({-class=>'content journal'});
  768. PrintJournal(map { GetParam($_, ''); } qw(num num regexp mode offset search variation));
  769. print $q->end_div();
  770. PrintFooter();
  771. }
  772. sub JournalSort { $b cmp $a }
  773. sub PrintJournal {
  774. return if $CollectingJournal; # avoid infinite loops
  775. local $CollectingJournal = 1;
  776. my ($num, $numMore, $regexp, $mode, $offset, $search, $variation) = @_;
  777. $variation ||= 'journal';
  778. $regexp ||= '^\d\d\d\d-\d\d-\d\d';
  779. $num ||= 10;
  780. $numMore = $num unless $numMore ne '';
  781. $offset ||= 0;
  782. # FIXME: Should pass filtered list of pages to SearchTitleAndBody to save time?
  783. my @pages = sort JournalSort (grep(/$regexp/, $search ? SearchTitleAndBody($search) : AllPagesList()));
  784. @pages = reverse @pages if $mode eq 'reverse' or $mode eq 'future';
  785. $b = $Today // CalcDay($Now);
  786. if ($mode eq 'future' || $mode eq 'past') {
  787. my $compare = $mode eq 'future' ? -1 : 1;
  788. for (my $i = 0; $i < @pages; $i++) {
  789. $a = $pages[$i];
  790. if (JournalSort() == $compare) {
  791. @pages = @pages[$i .. $#pages];
  792. last;
  793. }
  794. }
  795. }
  796. return unless $pages[$offset];
  797. print $q->start_div({-class=>'journal h-feed'});
  798. my $next = $offset + PrintAllPages(1, 1, $num, $variation, @pages[$offset .. $#pages]);
  799. print $q->end_div();
  800. $regexp = UrlEncode($regexp);
  801. $search = UrlEncode($search);
  802. if ($pages[$next] and $numMore != 0) {
  803. print $q->p({-class=>'more'}, ScriptLink("action=more;num=$numMore;regexp=$regexp;search=$search;mode=$mode;offset=$next;variation=$variation", T('More...'), 'more'));
  804. }
  805. }
  806. sub PrintAllPages {
  807. my ($links, $comments, $num, $variation, @pages) = @_;
  808. my $lang = GetParam('lang', 0);
  809. my ($i, $n) = 0;
  810. for my $id (@pages) {
  811. last if $n >= $JournalLimit and not UserIsAdmin() or $num and $n >= $num;
  812. $i++; # pages looked at
  813. local ($OpenPageName, %Page); # this is local!
  814. OpenPage($id);
  815. my @languages = split(/,/, $Page{languages});
  816. next if $lang and @languages and not grep(/$lang/, @languages);
  817. next if PageMarkedForDeletion();
  818. next if substr($Page{text}, 0, 10) eq '#REDIRECT ';
  819. print '<article class="h-entry">', $q->h1({-class => 'p-name'},
  820. $links ? GetPageLink($id) : $q->a({-name=>$id}, UrlEncode(FreeToNormal($id))));
  821. if ($variation ne 'titles') {
  822. PrintPageHtml();
  823. PrintPageCommentsLink($id, $comments);
  824. }
  825. print '</article>';
  826. $n++; # pages actually printed
  827. }
  828. return $i;
  829. }
  830. sub PrintPageCommentsLink {
  831. my ($id, $comments) = @_;
  832. if ($comments and $CommentsPattern and $id !~ /$CommentsPattern/) {
  833. print $q->p({-class=>'comment'},
  834. GetPageLink($CommentsPrefix . $id, T('Comments on this page')));
  835. }
  836. }
  837. sub RSS {
  838. return if $CollectingJournal; # avoid infinite loops when using full=1
  839. local $CollectingJournal = 1;
  840. my $maxitems = shift;
  841. my @uris = @_;
  842. my %lines;
  843. if (not eval { require XML::RSS; }) {
  844. my $err = $@;
  845. return $q->div({-class=>'rss'}, $q->p({-class=>'error'}, $q->strong(T('XML::RSS is not available on this system.')), $err));
  846. }
  847. # All strings that are concatenated with strings returned by the RSS
  848. # feed must be decoded. Without this decoding, 'diff' and 'history'
  849. # translations will be double encoded when printing the result.
  850. my $tDiff = T('diff');
  851. my $tHistory = T('history');
  852. my $wikins = 'http://purl.org/rss/1.0/modules/wiki/';
  853. my $rdfns = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
  854. @uris = map { my $x = $_; $x =~ s/^"?(.*?)"?$/$1/; $x; } @uris; # strip quotes of uris
  855. my ($str, %data) = GetRss(@uris);
  856. foreach my $uri (keys %data) {
  857. my $data = $data{$uri};
  858. if (not $data) {
  859. $str .= $q->p({-class=>'error'}, $q->strong(Ts('%s returned no data, or LWP::UserAgent is not available.',
  860. $q->a({-href=>$uri}, $uri))));
  861. } else {
  862. my $rss = new XML::RSS;
  863. eval { local $SIG{__DIE__}; $rss->parse($data); };
  864. if ($@) {
  865. $str .= $q->p({-class=>'error'}, $q->strong(Ts('RSS parsing failed for %s', $q->a({-href=>$uri}, $uri)) . ': ' . $@));
  866. } else {
  867. my $interwiki;
  868. if (@uris > 1) {
  869. RssInterwikiTranslateInit(); # not needed anywhere else thus init only now and not in ReInit
  870. $interwiki = $rss->{channel}->{$wikins}->{interwiki};
  871. $interwiki =~ s/^\s+//; # when RDF is used, sometimes whitespace remains,
  872. $interwiki =~ s/\s+$//; # which breaks the test for an existing $interwiki below
  873. $interwiki ||= $rss->{channel}->{$rdfns}->{value};
  874. $interwiki = $RssInterwikiTranslate{$interwiki} if $RssInterwikiTranslate{$interwiki};
  875. $interwiki ||= $RssInterwikiTranslate{$uri};
  876. }
  877. my $num = 999;
  878. $str .= $q->p({-class=>'error'}, $q->strong(Ts('No items found in %s.', $q->a({-href=>$uri}, $uri))))
  879. unless @{$rss->{items}};
  880. foreach my $i (@{$rss->{items}}) {
  881. my $line;
  882. my $date = $i->{dc}->{date};
  883. if (not $date and $i->{pubDate}) {
  884. $date = $i->{pubDate};
  885. my %mon = (Jan=>1, Feb=>2, Mar=>3, Apr=>4, May=>5, Jun=>6,
  886. Jul=>7, Aug=>8, Sep=>9, Oct=>10, Nov=>11, Dec=>12);
  887. $date =~ s/^(?:[A-Z][a-z][a-z], )?(\d\d?) ([A-Z][a-z][a-z]) (\d\d(?:\d\d)?)/ # pubDate uses RFC 822
  888. sprintf('%04d-%02d-%02d', ($3 < 100 ? 1900 + $3 : $3), $mon{$2}, $1)/e;
  889. }
  890. $date ||= sprintf("%03d", $num--); # for RSS 0.91 feeds without date, descending
  891. my $title = $i->{title};
  892. my $description = $i->{description};
  893. if (not $title and $description) { # title may be missing in RSS 2.00
  894. $title = $description;
  895. $description = '';
  896. }
  897. $title = $i->{link} if not $title and $i->{link}; # if description and title are missing
  898. $line .= ' (' . $q->a({-href=>$i->{$wikins}->{diff}}, $tDiff) . ')' if $i->{$wikins}->{diff};
  899. $line .= ' (' . $q->a({-href=>$i->{$wikins}->{history}}, $tHistory) . ')' if $i->{$wikins}->{history};
  900. if ($title) {
  901. if ($i->{link}) {
  902. $line .= ' ' . $q->a({-href=>$i->{link}, -title=>$date},
  903. ($interwiki ? $interwiki . ':' : '') . $title);
  904. } else {
  905. $line .= ' ' . $title;
  906. }
  907. }
  908. my $contributor = $i->{dc}->{contributor};
  909. $contributor ||= $i->{$wikins}->{username};
  910. $contributor =~ s/^\s+//;
  911. $contributor =~ s/\s+$//;
  912. $contributor ||= $i->{$rdfns}->{value};
  913. $line .= $q->span({-class=>'contributor'}, $q->span(T(' . . . .') . ' ') . $contributor) if $contributor;
  914. if ($description) {
  915. if ($description =~ /</) {
  916. $line .= $q->div({-class=>'description'}, $description);
  917. } else {
  918. $line .= $q->span({class=>'dash'}, ' &#8211; ') . $q->strong({-class=>'description'}, $description);
  919. }
  920. }
  921. $date .= ' ' while ($lines{$date}); # make sure this is unique
  922. $lines{$date} = $line;
  923. }
  924. }
  925. }
  926. }
  927. my @lines = sort { $b cmp $a } keys %lines;
  928. @lines = @lines[0 .. $maxitems-1] if $maxitems and $#lines > $maxitems;
  929. my $date = '';
  930. foreach my $key (@lines) {
  931. my $line = $lines{$key};
  932. if ($key =~ /(\d\d\d\d(?:-\d?\d)?(?:-\d?\d)?)(?:[T ](\d?\d:\d\d))?/) {
  933. my ($day, $time) = ($1, $2);
  934. if ($day ne $date) {
  935. $str .= '</ul>' if $date; # close ul except for the first time where no open ul exists
  936. $date = $day;
  937. $str .= $q->p($q->strong($day)) . '<ul>';
  938. }
  939. $line = $q->span({-class=>'time'}, $time . ' UTC ') . $line if $time;
  940. } elsif (not $date) {
  941. $str .= '<ul>'; # if the feed doesn't have any dates we need to start the list anyhow
  942. $date = $Now; # to ensure the list starts only once
  943. }
  944. $str .= $q->li($line);
  945. }
  946. $str .= '</ul>' if $date;
  947. return $q->div({-class=>'rss'}, $str);
  948. }
  949. sub GetRss {
  950. my %todo = map {$_, GetRssFile($_)} @_;
  951. my %data = ();
  952. my $str = '';
  953. if (GetParam('cache', $UseCache) > 0) {
  954. foreach my $uri (keys %todo) { # read cached rss files if possible
  955. if ($Now - Modified($todo{$uri}) < $RssCacheHours * 3600) {
  956. $data{$uri} = ReadFile($todo{$uri});
  957. delete($todo{$uri}); # no need to fetch them below
  958. }
  959. }
  960. }
  961. my @need_cache = keys %todo;
  962. if (keys %todo > 1) { # try parallel access if available
  963. eval { # see code example in LWP::Parallel, not LWP::Parallel::UserAgent (no callbacks here)
  964. require LWP::Parallel::UserAgent;
  965. my $pua = LWP::Parallel::UserAgent->new();
  966. foreach my $uri (keys %todo) {
  967. if (my $res = $pua->register(HTTP::Request->new('GET', $uri))) {
  968. $str .= $res->error_as_HTML;
  969. }
  970. }
  971. %todo = (); # because the uris in the response may have changed due to redirects
  972. my $entries = $pua->wait();
  973. foreach (keys %$entries) {
  974. my $uri = $entries->{$_}->request->uri;
  975. $data{$uri} = $entries->{$_}->response->decoded_content;
  976. }
  977. }
  978. }
  979. foreach my $uri (keys %todo) { # default operation: synchronous fetching
  980. $data{$uri} = GetRaw($uri);
  981. }
  982. if (GetParam('cache', $UseCache) > 0) {
  983. CreateDir($RssDir);
  984. foreach my $uri (@need_cache) {
  985. my $data = $data{$uri};
  986. # possibly a Latin-1 file without encoding attribute will cause a problem?
  987. $data =~ s/encoding="[^"]*"/encoding="UTF-8"/; # content was converted
  988. WriteStringToFile(GetRssFile($uri), $data) if $data;
  989. }
  990. }
  991. return $str, %data;
  992. }
  993. sub GetRssFile {
  994. return $RssDir . '/' . UrlEncode(shift);
  995. }
  996. sub RssInterwikiTranslateInit {
  997. return unless $RssInterwikiTranslate;
  998. %RssInterwikiTranslate = ();
  999. foreach (split(/\n/, GetPageContent($RssInterwikiTranslate))) {
  1000. if (/^ ([^ ]+)[ \t]+([^ ]+)$/) {
  1001. $RssInterwikiTranslate{$1} = $2;
  1002. }
  1003. }
  1004. }
  1005. sub GetInterSiteUrl {
  1006. my ($site, $page, $quote) = @_;
  1007. return unless $page;
  1008. $page = join('/', map { UrlEncode($_) } split(/\//, $page)) if $quote; # Foo:bar+baz is not quoted, [[Foo:bar baz]] is.
  1009. my $url = $InterSite{$site} or return;
  1010. $url =~ s/\%s/$page/g or $url .= $page;
  1011. return $url;
  1012. }
  1013. sub BracketLink { # brackets can be removed via CSS
  1014. return $q->span($q->span({class=>'bracket'}, '[') . (shift) . $q->span({class=>'bracket'}, ']'));
  1015. }
  1016. sub GetInterLink {
  1017. my ($id, $text, $bracket, $quote) = @_;
  1018. my ($site, $page) = split(/:/, $id, 2);
  1019. $page =~ s/&amp;/&/g; # Unquote common URL HTML
  1020. my $url = GetInterSiteUrl($site, $page, $quote);
  1021. my $class = 'inter ' . $site;
  1022. return "[$id $text]" if $text and $bracket and not $url;
  1023. return "[$id]" if $bracket and not $url;
  1024. return $id if not $url;
  1025. if ($bracket and not $text) {
  1026. $text = BracketLink(++$FootnoteNumber);
  1027. $class .= ' number';
  1028. } elsif (not $text) {
  1029. $text = $q->span({-class=>'site'}, $site)
  1030. . $q->span({-class=>'separator'}, ':')
  1031. . $q->span({-class=>'interpage'}, $page);
  1032. } elsif ($bracket) { # and $text is set
  1033. $class .= ' outside';
  1034. }
  1035. return $q->a({-href=>$url, -class=>$class}, $text);
  1036. }
  1037. sub InterInit {
  1038. %InterSite = ();
  1039. foreach (split(/\n/, GetPageContent($InterMap))) {
  1040. if (/^ ($InterSitePattern)[ \t]+([^ ]+)$/) {
  1041. $InterSite{$1} = $2;
  1042. }
  1043. }
  1044. }
  1045. sub GetUrl {
  1046. my ($url, $text, $bracket, $images) = @_;
  1047. $url =~ /^($UrlProtocols)/;
  1048. my $class = "url $1";
  1049. if ($NetworkFile && $url =~ m|^file:///| && !$AllNetworkFiles
  1050. or !$NetworkFile && $url =~ m|^file:|) {
  1051. # Only do remote file:// links. No file:///c|/windows.
  1052. return $url;
  1053. } elsif ($bracket and not defined $text) {
  1054. $text = BracketLink(++$FootnoteNumber);
  1055. $class .= ' number';
  1056. } elsif (not defined $text) {
  1057. $text = $url;
  1058. } elsif ($bracket) { # and $text is set
  1059. $class .= ' outside';
  1060. }
  1061. $url = UnquoteHtml($url); # links should be unquoted again
  1062. if ($images and $url =~ /^(http:|https:|ftp:).+\.$ImageExtensions$/i) {
  1063. return $q->img({-src=>$url, -alt=>$url, -class=>$class, -loading=>'lazy'});
  1064. } else {
  1065. return $q->a({-href=>$url, -class=>$class}, $text);
  1066. }
  1067. }
  1068. sub GetPageOrEditLink { # use GetPageLink and GetEditLink if you know the result!
  1069. my ($id, $text, $bracket, $free) = @_;
  1070. $id = FreeToNormal($id);
  1071. my ($class, $resolved, $title, $exists) = ResolveId($id);
  1072. if (not $text and $resolved and $bracket) {
  1073. $text = BracketLink(++$FootnoteNumber);
  1074. $class .= ' number';
  1075. $title = NormalToFree($id);
  1076. }
  1077. my $link = $text || NormalToFree($id);
  1078. if ($resolved) { # anchors don't exist as pages, therefore do not use $exists
  1079. return ScriptLink(UrlEncode($resolved), $link, $class, undef, $title);
  1080. } else { # reproduce markup if $UseQuestionmark
  1081. return GetEditLink($id, UnquoteHtml($bracket ? "[$link]" : $link)) unless $UseQuestionmark;
  1082. $link = QuoteHtml($id) . GetEditLink($id, '?');
  1083. $link .= ($free ? '|' : ' ') . $text if $text and FreeToNormal($text) ne $id;
  1084. $link = "[[$link]]" if $free;
  1085. $link = "[$link]" if $bracket or not $free and $text;
  1086. return $link;
  1087. }
  1088. }
  1089. sub GetPageLink { # use if you want to force a link to local pages, whether it exists or not
  1090. my ($id, $name, $class, $accesskey) = @_;
  1091. $id = FreeToNormal($id);
  1092. $name ||= $id;
  1093. $class .= ' ' if $class;
  1094. return ScriptLink(UrlEncode($id), NormalToFree($name), $class . 'local',
  1095. undef, undef, $accesskey);
  1096. }
  1097. sub GetEditLink { # shortcut
  1098. my ($id, $name, $upload, $accesskey) = @_;
  1099. $id = FreeToNormal($id);
  1100. my $action = 'action=edit;id=' . UrlEncode($id);
  1101. $action .= ';upload=1' if $upload;
  1102. return ScriptLink($action, NormalToFree($name), 'edit', undef, T('Click to edit this page'), $accesskey);
  1103. }
  1104. sub ScriptUrl {
  1105. my $action = shift;
  1106. if ($action =~ /^($UrlProtocols)\%3a/ or $action =~ /^\%2f/) { # nearlinks and other URLs
  1107. $action =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/eg; # undo urlencode
  1108. # do nothing
  1109. } else {
  1110. $action = $ScriptName . (($UsePathInfo and index($action, '=') == -1) ? '/' : '?') . $action;
  1111. }
  1112. return $action unless wantarray;
  1113. return ($action, index($action, '=') != -1);
  1114. }
  1115. sub ScriptLink {
  1116. my ($action, $text, $class, $name, $title, $accesskey) = @_;
  1117. my ($url, $nofollow) = ScriptUrl($action);
  1118. my %params;
  1119. $params{-href} = $url;
  1120. $params{'-rel'} = 'nofollow' if $nofollow;
  1121. $params{'-class'} = $class if $class;
  1122. $params{'-name'} = $name if $name;
  1123. $params{'-title'} = $title if $title;
  1124. $params{'-accesskey'} = $accesskey if $accesskey;
  1125. return $q->a(\%params, $text);
  1126. }
  1127. sub GetDownloadLink {
  1128. my ($id, $image, $revision, $alt) = @_;
  1129. $alt ||= NormalToFree($id);
  1130. # if the page does not exist
  1131. return '[[' . ($image ? 'image' : 'download') . ':'
  1132. . ($UseQuestionmark ? QuoteHtml($id) . GetEditLink($id, '?', 1)
  1133. : GetEditLink($id, $id, 1)) . ']]'
  1134. unless $IndexHash{$id};
  1135. my $action;
  1136. if ($revision) {
  1137. $action = "action=download;id=" . UrlEncode($id) . ";revision=$revision";
  1138. } elsif ($UsePathInfo) {
  1139. $action = "download/" . UrlEncode($id);
  1140. } else {
  1141. $action = "action=download;id=" . UrlEncode($id);
  1142. }
  1143. if ($image) {
  1144. $action = $ScriptName . (($UsePathInfo and not $revision) ? '/' : '?') . $action;
  1145. return $action if $image == 2;
  1146. my $result = $q->img({-src=>$action, -alt=>UnquoteHtml($alt), -title=>UnquoteHtml($alt),
  1147. -class=>'upload', -loading=>'lazy'});
  1148. $result = ScriptLink(UrlEncode($id), $result, 'image') unless $id eq $OpenPageName;
  1149. return $result;
  1150. } else {
  1151. return ScriptLink($action, $alt, 'upload');
  1152. }
  1153. }
  1154. sub PrintCache { # Use after OpenPage!
  1155. my @blocks = split($FS, $Page{blocks});
  1156. my @flags = split($FS, $Page{flags});
  1157. $FootnoteNumber = 0;
  1158. foreach my $block (@blocks) {
  1159. if (shift(@flags)) {
  1160. ApplyRules($block, 1, 1); # local links, anchors, current revision, no start tag
  1161. } else {
  1162. print $block;
  1163. }
  1164. }
  1165. }
  1166. sub PrintPageHtml { # print an open page
  1167. return unless GetParam('page', 1) and $Page{text};
  1168. my $lang = (split /,/, $Page{languages})[0] || $CurrentLanguage;
  1169. print qq{<div class="e-content" lang="$lang">};
  1170. if ($Page{blocks} and defined $Page{flags} and GetParam('cache', $UseCache) > 0) {
  1171. PrintCache();
  1172. } else {
  1173. PrintWikiToHTML($Page{text}, 1); # save cache, current revision, no main lock
  1174. }
  1175. print '</div>';
  1176. }
  1177. sub PrintPageDiff { # print diff for open page
  1178. my $diff = GetParam('diff', 0);
  1179. if ($UseDiff and $diff) {
  1180. PrintHtmlDiff($diff);
  1181. print $q->hr() if GetParam('page', 1);
  1182. }
  1183. }
  1184. sub ToString {
  1185. my $sub_ref = shift;
  1186. my $output;
  1187. open(my $outputFH, '>:encoding(UTF-8)', \$output) or die "Can't open memory file: $!";
  1188. my $oldFH = select $outputFH;
  1189. $sub_ref->(@_);
  1190. select $oldFH;
  1191. close $outputFH;
  1192. return decode_utf8($output);
  1193. }
  1194. sub PageHtml {
  1195. my ($id, $limit, $error) = @_;
  1196. OpenPage($id);
  1197. my $diff = ToString \&PrintPageDiff;
  1198. return $error if $limit and length($diff) > $limit;
  1199. my $lang = (split /,/, $Page{languages})[0] // $CurrentLanguage;
  1200. my $page .= ToString \&PrintPageHtml;
  1201. return $diff . $q->p($error) if $limit and length($diff . $page) > $limit;
  1202. return $diff . $page;
  1203. }
  1204. sub T {
  1205. my $text = shift;
  1206. return $Translate{$text} || $text;
  1207. }
  1208. sub Ts {
  1209. my ($text, $string) = @_;
  1210. $text = T($text);
  1211. $text =~ s/\%s/$string/ if defined($string);
  1212. return $text;
  1213. }
  1214. sub Tss {
  1215. my $text = $_[0];
  1216. $text = T($text);
  1217. $text =~ s/\%([1-9])/$_[$1]/eg;
  1218. return $text;
  1219. }
  1220. sub GetId {
  1221. my $id = UnquoteHtml(GetParam('id', GetParam('title', ''))); # id=x or title=x -> x
  1222. if (not $id and $q->keywords) {
  1223. $id = decode_utf8(join('_', $q->keywords)); # script?p+q -> p_q
  1224. }
  1225. if ($UsePathInfo and $q->path_info) {
  1226. my @path = map { decode_utf8($_) } split(/\//, $q->path_info);
  1227. $id ||= pop(@path); # script/p/q -> q
  1228. foreach my $p (@path) {
  1229. SetParam($p, 1); # script/p/q -> p=1
  1230. }
  1231. }
  1232. return $id;
  1233. }
  1234. sub DoBrowseRequest {
  1235. # We can use the error message as the HTTP error code
  1236. ReportError(Ts('CGI Internal error: %s', $q->cgi_error), $q->cgi_error) if $q->cgi_error;
  1237. print $q->header(-status=>'304 NOT MODIFIED') and return if PageFresh(); # return value is ignored
  1238. my $id = GetId();
  1239. my $action = lc(GetParam('action', '')); # script?action=foo;id=bar
  1240. $action = 'download' if GetParam('download', '') and not $action; # script/download/id
  1241. if ($Action{$action}) {
  1242. &{$Action{$action}}($id);
  1243. } elsif ($action and defined &MyActions) {
  1244. eval { local $SIG{__DIE__}; MyActions(); };
  1245. } elsif ($action) {
  1246. ReportError(Ts('Invalid action parameter %s', $action), '501 NOT IMPLEMENTED');
  1247. } elsif (GetParam('search', '') ne '') { # allow search for "0"
  1248. SetParam('action', 'search'); # make sure this gets a NOINDEX
  1249. DoSearch();
  1250. } elsif (GetParam('match', '') ne '') {
  1251. SetParam('action', 'index'); # make sure this gets a NOINDEX
  1252. DoIndex();
  1253. } elsif (GetParam('title', '') and not GetParam('Cancel', '')) {
  1254. DoPost(GetParam('title', ''));
  1255. } else {
  1256. BrowseResolvedPage($id || $HomePage); # default action!
  1257. }
  1258. }
  1259. sub ValidId { # hack alert: returns error message if invalid, and unfortunately the empty string if valid!
  1260. my $id = FreeToNormal(shift);
  1261. return T('Page name is missing') unless $id;
  1262. require bytes;
  1263. return Ts('Page name is too long: %s', $id) if bytes::length($id) > $PageNameLimit;
  1264. return Ts('Invalid Page %s (must not end with .db)', $id) if $id =~ m|\.db$|;
  1265. return Ts('Invalid Page %s (must not end with .lck)', $id) if $id =~ m|\.lck$|;
  1266. return Ts('Invalid Page %s', $id) if $FreeLinks ? $id !~ m|^$FreeLinkPattern$| : $id !~ m|^$LinkPattern$|;
  1267. }
  1268. sub ValidIdOrDie {
  1269. my $id = shift;
  1270. my $error = ValidId($id);
  1271. ReportError($error, '400 BAD REQUEST') if $error;
  1272. return 1;
  1273. }
  1274. sub ResolveId { # return css class, resolved id, title (eg. for popups), exist-or-not
  1275. my $id = shift;
  1276. return ('local', $id, '', 1) if $IndexHash{$id};
  1277. return ('', '', '', '');
  1278. }
  1279. sub BrowseResolvedPage {
  1280. my $id = FreeToNormal(shift);
  1281. my ($class, $resolved, $title, $exists) = ResolveId($id);
  1282. if ($class and $class eq 'near' and not GetParam('rcclusteronly', 0)) { # nearlink (is url)
  1283. print $q->redirect({-uri=>$resolved});
  1284. } elsif ($class and $class eq 'alias') { # an anchor was found instead of a page
  1285. ReBrowsePage($resolved);
  1286. } elsif (not $resolved and $NotFoundPg and $id !~ /$CommentsPattern/) { # custom page-not-found message
  1287. BrowsePage($NotFoundPg);
  1288. } elsif ($resolved or $id =~ /$CommentsPattern/ and $1 and $IndexHash{$1}) { # an existing page
  1289. BrowsePage(($resolved or $id), GetParam('raw', 0));
  1290. } else { # new page!
  1291. BrowsePage($id, GetParam('raw', 0), undef, '404 NOT FOUND') if ValidIdOrDie($id);
  1292. }
  1293. }
  1294. sub NewText { # only if no revision is available
  1295. my $id = shift;
  1296. if ($CommentsPrefix and $id =~ /^($CommentsPrefix)/) {
  1297. return T('There are no comments, yet. Be the first to leave a comment!');
  1298. } elsif ($id eq $HomePage) {
  1299. return T('Welcome!');
  1300. } else {
  1301. return Ts('This page does not exist, but you can %s.',
  1302. '[' . ScriptUrl('action=edit;id=' . UrlEncode($id)) . ' '
  1303. . T('create it now') . ']');
  1304. }
  1305. }
  1306. sub BrowsePage {
  1307. my ($id, $raw, $comment, $status) = @_;
  1308. OpenPage($id);
  1309. my ($revisionPage, $revision) = GetTextRevision(GetParam('revision', ''));
  1310. my $text = $revisionPage->{text};
  1311. $text = NewText($id) unless $revision or $Page{revision} or $comment; # new text for new pages
  1312. # handle a single-level redirect
  1313. my $oldId = GetParam('oldid', '');
  1314. if ((substr($text, 0, 10) eq '#REDIRECT ')) {
  1315. if ($oldId) {
  1316. $Message .= $q->p(T('Too many redirections'));
  1317. } elsif ($revision) {
  1318. $Message .= $q->p(T('No redirection for old revisions'));
  1319. } elsif (($FreeLinks and $text =~ /^\#REDIRECT\s+\[\[$FreeLinkPattern\]\]/)
  1320. or ($WikiLinks and $text =~ /^\#REDIRECT\s+$LinkPattern/)) {
  1321. return ReBrowsePage(FreeToNormal($1), $id);
  1322. } else {
  1323. $Message .= $q->p(T('Invalid link pattern for #REDIRECT'));
  1324. }
  1325. }
  1326. # shortcut if we only need the raw text: no caching, no diffs, no html.
  1327. if ($raw) {
  1328. print GetHttpHeader('text/plain', $Page{ts}, $IndexHash{$id} ? undef : '404 NOT FOUND');
  1329. print $Page{ts} . " # Do not delete this line when editing!\n" if $raw == 2;
  1330. print $text;
  1331. return;
  1332. }
  1333. # normal page view
  1334. my $msg = GetParam('msg', '');
  1335. $Message .= $q->p($msg) if $msg; # show message if the page is shown
  1336. SetParam('msg', '');
  1337. print GetHeader($id, NormalToFree($id), $oldId, undef, $status);
  1338. my $showDiff = GetParam('diff', 0);
  1339. if ($UseDiff and $showDiff) {
  1340. PrintHtmlDiff($showDiff, GetParam('diffrevision'), $revisionPage, $Page{revision});
  1341. print $q->hr();
  1342. }
  1343. PrintPageContent($text, $revision, $comment);
  1344. SetParam('rcclusteronly', $id) if FreeToNormal(GetCluster($text)) eq $id; # automatically filter by cluster
  1345. PrintRcHtml($id);
  1346. PrintFooter($id, $revision, $comment, $revisionPage);
  1347. }
  1348. sub ReBrowsePage {
  1349. my ($id, $oldId) = map { UrlEncode($_); } @_; # encode before printing URL
  1350. if ($oldId) { # Target of #REDIRECT (loop breaking)
  1351. print GetRedirectPage("action=browse;oldid=$oldId;id=$id", $id);
  1352. } else {
  1353. print GetRedirectPage($id, $id);
  1354. }
  1355. }
  1356. sub GetRedirectPage {
  1357. my ($action, $name) = @_;
  1358. my ($url, $html);
  1359. if (GetParam('raw', 0)) {
  1360. $html = GetHttpHeader('text/plain');
  1361. $html .= Ts('Please go on to %s.', $action); # no redirect
  1362. return $html;
  1363. }
  1364. $url = $ScriptName . (($UsePathInfo and $action !~ /=/) ? '/' : '?') . $action;
  1365. my $nameLink = $q->a({-href=>$url}, $name);
  1366. my %headers = (-uri=>$url);
  1367. my $cookie = Cookie();
  1368. $headers{-cookie} = $cookie if $cookie;
  1369. return $q->redirect(%headers);
  1370. }
  1371. sub DoRandom {
  1372. my @pages = AllPagesList();
  1373. ReBrowsePage($pages[int(rand($#pages + 1))]);
  1374. }
  1375. sub PageFresh { # pages can depend on other pages (ie. last update), admin status, and css
  1376. return 1 if $q->http('HTTP_IF_NONE_MATCH') and GetParam('cache', $UseCache) >= 2
  1377. and $q->http('HTTP_IF_NONE_MATCH') eq PageEtag();
  1378. }
  1379. sub PageEtag {
  1380. my ($changed, %params) = CookieData();
  1381. return UrlEncode(join($FS, $LastUpdate||$Now, sort(values %params))); # no CTL in field values
  1382. }
  1383. sub FileFresh { # old files are never stale, current files are stale when the page was modified
  1384. return 1 if $q->http('HTTP_IF_NONE_MATCH') and GetParam('cache', $UseCache) >= 2
  1385. and (GetParam('revision', 0) or $q->http('HTTP_IF_NONE_MATCH') eq $Page{ts});
  1386. }
  1387. sub BrowseRc {
  1388. my $id = shift;
  1389. if (GetParam('raw', 0)) {
  1390. print GetHttpHeader('text/plain');
  1391. PrintRcText();
  1392. } else {
  1393. PrintRcHtml($id || $RCName, 1);
  1394. }
  1395. }
  1396. sub GetRcLines { # starttime, hash of seen pages to use as a second return value
  1397. my $starttime = shift || GetParam('from', 0) ||
  1398. $Now - GetParam('days', $RcDefault) * 86400; # 24*60*60
  1399. my $filterOnly = GetParam('rcfilteronly', '');
  1400. # these variables apply accross logfiles
  1401. my %match = $filterOnly ? map { $_ => 1 } SearchTitleAndBody($filterOnly) : ();
  1402. my %following = ();
  1403. my @result = ();
  1404. my $ts;
  1405. # check the first timestamp in the default file, maybe read old log file
  1406. if (open(my $F, '<:encoding(UTF-8)', encode_utf8($RcFile))) {
  1407. my $line = <$F>;
  1408. ($ts) = split(/$FS/, $line); # the first timestamp in the regular rc file
  1409. }
  1410. if (not $ts or $ts > $starttime) { # we need to read the old rc file, too
  1411. push(@result, GetRcLinesFor($RcOldFile, $starttime, \%match, \%following));
  1412. }
  1413. push(@result, GetRcLinesFor($RcFile, $starttime, \%match, \%following));
  1414. # GetRcLinesFor is trying to save memory space, but some operations
  1415. # can only happen once we have all the data.
  1416. return LatestChanges(StripRollbacks(@result));
  1417. }
  1418. sub LatestChanges {
  1419. my $all = GetParam('all', $ShowAll);
  1420. my @result = @_;
  1421. my %seen = ();
  1422. for (my $i = $#result; $i >= 0; $i--) {
  1423. my $id = $result[$i][1];
  1424. if ($all) {
  1425. $result[$i][9] = 1 unless $seen{$id}; # mark latest edit
  1426. } else {
  1427. splice(@result, $i, 1) if $seen{$id}; # remove older edits
  1428. }
  1429. $seen{$id} = 1;
  1430. }
  1431. my $to = GetParam('upto', 0);
  1432. if ($to) {
  1433. for (my $i = 0; $i < $#result; $i++) {
  1434. if ($result[$i][0] > $to) {
  1435. splice(@result, $i);
  1436. last;
  1437. }
  1438. }
  1439. }
  1440. return reverse @result;
  1441. }
  1442. sub StripRollbacks {
  1443. my @result = @_;
  1444. if (not (GetParam('all', $ShowAll) or GetParam('rollback', $ShowRollbacks))) { # strip rollbacks
  1445. my (%rollback);
  1446. for (my $i = $#result; $i >= 0; $i--) {
  1447. # some fields have a different meaning if looking at rollbacks
  1448. my ($ts, $id, $target_ts, $target_id) = @{$result[$i]};
  1449. if ($id eq '[[rollback]]') {
  1450. if ($target_id) {
  1451. $rollback{$target_id} = $target_ts; # single page rollback
  1452. splice(@result, $i, 1); # strip marker
  1453. } else {
  1454. my $end = $i;
  1455. while ($ts > $target_ts and $i > 0) {
  1456. $i--; # quickly skip all these lines
  1457. $ts = $result[$i][0];
  1458. }
  1459. splice(@result, $i + 1, $end - $i);
  1460. $i++; # compensate $i-- in for loop
  1461. }
  1462. } elsif ($rollback{$id} and $ts > $rollback{$id}) {
  1463. splice(@result, $i, 1); # strip rolled back single pages
  1464. }
  1465. }
  1466. } else { # just strip the marker left by DoRollback()
  1467. for (my $i = $#result; $i >= 0; $i--) {
  1468. splice(@result, $i, 1) if $result[$i][1] eq '[[rollback]]'; # id
  1469. }
  1470. }
  1471. return @result;
  1472. }
  1473. sub GetRcLinesFor {
  1474. my $file = shift;
  1475. my $starttime = shift;
  1476. my %match = %{$_[0]}; # deref
  1477. my %following = %{$_[1]}; # deref
  1478. # parameters
  1479. my $showminoredit = GetParam('showedit', $ShowEdits); # show minor edits
  1480. my $all = GetParam('all', $ShowAll);
  1481. my ($idOnly, $userOnly, $hostOnly, $clusterOnly, $filterOnly, $match, $lang,
  1482. $followup) = map { UnquoteHtml(GetParam($_, '')); }
  1483. qw(rcidonly rcuseronly rchostonly
  1484. rcclusteronly rcfilteronly match lang followup);
  1485. # parsing and filtering
  1486. my @result = ();
  1487. open(my $F, '<:encoding(UTF-8)', encode_utf8($file)) or return ();
  1488. while (my $line = <$F>) {
  1489. chomp($line);
  1490. my ($ts, $id, $minor, $summary, $host, $username, $revision,
  1491. $languages, $cluster) = split(/$FS/, $line);
  1492. next if $ts < $starttime;
  1493. $following{$id} = $ts if $followup and $followup eq $username;
  1494. next if $followup and (not $following{$id} or $ts <= $following{$id});
  1495. next if $idOnly and $idOnly ne $id;
  1496. next if $filterOnly and not $match{$id};
  1497. next if ($userOnly and $userOnly ne $username);
  1498. next if $minor == 1 and not $showminoredit; # skip minor edits (if [[rollback]] this is bogus)
  1499. next if not $minor and $showminoredit == 2; # skip major edits
  1500. next if $match and $id !~ /$match/i;
  1501. next if $hostOnly and $host !~ /$hostOnly/i;
  1502. my @languages = split(/,/, $languages);
  1503. next if $lang and @languages and not grep(/$lang/, @languages);
  1504. if ($PageCluster) {
  1505. ($cluster, $summary) = ($1, $2) if $summary =~ /^\[\[$FreeLinkPattern\]\] ?: *(.*)/
  1506. or $summary =~ /^$LinkPattern ?: *(.*)/;
  1507. next if ($clusterOnly and $clusterOnly ne $cluster);
  1508. $cluster = '' if $clusterOnly; # don't show cluster if $clusterOnly eq $cluster
  1509. if ($all < 2 and not $clusterOnly and $cluster) {
  1510. $summary = "$id: $summary"; # print the cluster instead of the page
  1511. $id = $cluster;
  1512. $revision = '';
  1513. }
  1514. } else {
  1515. $cluster = '';
  1516. }
  1517. $following{$id} = $ts if $followup and $followup eq $username;
  1518. push(@result, [$ts, $id, $minor, $summary, $host, $username, $revision,
  1519. \@languages, $cluster]);
  1520. }
  1521. return @result;
  1522. }
  1523. sub ProcessRcLines {
  1524. my ($printDailyTear, $printRCLine) = @_; # code references
  1525. # needed for output
  1526. my $date = '';
  1527. for my $line (GetRcLines()) {
  1528. my ($ts, $id, $minor, $summary, $host, $username, $revision, $languageref,
  1529. $cluster, $last) = @$line;
  1530. if ($date ne CalcDay($ts)) {
  1531. $date = CalcDay($ts);
  1532. $printDailyTear->($date);
  1533. }
  1534. $printRCLine->($id, $ts, $host, $username, $summary, $minor, $revision,
  1535. $languageref, $cluster, $last);
  1536. }
  1537. }
  1538. sub RcHeader {
  1539. my ($from, $upto, $html) = (GetParam('from', 0), GetParam('upto', 0), '');
  1540. my $days = GetParam('days') + 0 || $RcDefault; # force numeric $days
  1541. my $all = GetParam('all', $ShowAll);
  1542. my $edits = GetParam('showedit', $ShowEdits);
  1543. my $rollback = GetParam('rollback', $ShowRollbacks);
  1544. if ($from) {
  1545. $html .= $q->h2(Ts('Updates since %s', TimeToText(GetParam('from', 0))) . ' '
  1546. . ($upto ? Ts('up to %s', TimeToText($upto)) : ''));
  1547. } else {
  1548. $html .= $q->h2((GetParam('days', $RcDefault) != 1)
  1549. ? Ts('Updates in the last %s days', $days)
  1550. : Ts('Updates in the last day'));
  1551. }
  1552. my $action = '';
  1553. my ($idOnly, $userOnly, $hostOnly, $clusterOnly, $filterOnly,
  1554. $match, $lang, $followup) =
  1555. map {
  1556. my $val = GetParam($_, '');
  1557. $html .= $q->p($q->b('(' . Ts('for %s only', $val) . ')')) if $val;
  1558. $action .= ";$_=$val" if $val; # remember these parameters later!
  1559. $val;
  1560. } qw(rcidonly rcuseronly rchostonly rcclusteronly rcfilteronly
  1561. match lang followup);
  1562. my $rss = "action=rss$action;days=$days;all=$all;showedit=$edits";
  1563. if ($clusterOnly) {
  1564. $action = GetPageParameters('browse', $clusterOnly) . $action;
  1565. } else {
  1566. $action = "action=rc$action";
  1567. }
  1568. my @menu;
  1569. if ($all) {
  1570. push(@menu, ScriptLink("$action;days=$days;all=0;showedit=$edits",
  1571. T('List latest change per page only')));
  1572. } else {
  1573. push(@menu, ScriptLink("$action;days=$days;all=1;showedit=$edits",
  1574. T('List all changes')));
  1575. if ($rollback) {
  1576. push(@menu, ScriptLink("$action;days=$days;all=0;rollback=0;"
  1577. . "showedit=$edits", T('Skip rollbacks')));
  1578. } else {
  1579. push(@menu, ScriptLink("$action;days=$days;all=0;rollback=1;"
  1580. . "showedit=$edits", T('Include rollbacks')));
  1581. }
  1582. }
  1583. if ($edits) {
  1584. push(@menu, ScriptLink("$action;days=$days;all=$all;showedit=0",
  1585. T('List only major changes')));
  1586. } else {
  1587. push(@menu, ScriptLink("$action;days=$days;all=$all;showedit=1",
  1588. T('Include minor changes')));
  1589. }
  1590. $html .= $q->p(join(' | ', (map { ScriptLink("$action;days=$_;all=$all;showedit=$edits", $_); } @RcDays)),
  1591. T('days'), $q->br(), @menu, $q->br(),
  1592. ScriptLink($action . ';from=' . ($LastUpdate + 1)
  1593. . ";all=$all;showedit=$edits", T('List later changes')),
  1594. ScriptLink($rss, T('RSS'), 'rss nopages nodiff'),
  1595. ScriptLink("$rss;full=1", T('RSS with pages'), 'rss pages nodiff'),
  1596. ScriptLink("$rss;full=1;diff=1", T('RSS with pages and diff'),
  1597. 'rss pages diff'));
  1598. $html .= $q->p({-class => 'documentation'}, T('Using the 「rollback」 button on this page will reset the wiki to that particular point in time, undoing any later changes to all of the pages.')) if UserIsAdmin() and GetParam('all', $ShowAll);
  1599. return $html;
  1600. }
  1601. sub RcOtherParameters {
  1602. my $more = '';
  1603. foreach (@_, qw(page diff full all showedit rollback rcidonly rcuseronly rchostonly rcclusteronly rcfilteronly match lang followup)) {
  1604. my $val = GetParam($_, '');
  1605. $more .= ";$_=" . UrlEncode($val) if $val;
  1606. }
  1607. return $more;
  1608. }
  1609. sub RcSelfAction {
  1610. my $action = GetParam('action', 'rc');
  1611. return "action=$action" . RcOtherParameters(qw(from upto days));
  1612. }
  1613. sub RcPreviousAction {
  1614. my $action = GetParam('action', 'rc');
  1615. my $interval = GetParam('days', $RcDefault) * 86400;
  1616. # use delta between from and upto, or use days, whichever is available
  1617. my $to = GetParam('from', GetParam('upto', $Now - $interval));
  1618. my $from = $to - (GetParam('upto') ? GetParam('upto') - GetParam('from') : $interval);
  1619. return "action=$action;from=$from;upto=$to" . RcOtherParameters();
  1620. }
  1621. sub RcLastAction {
  1622. my $action = GetParam('action', 'rc');
  1623. my $more = "action=$action";
  1624. my $days = GetParam('days', $RcDefault);
  1625. $more .= ";days=$days" if $days != $RcDefault;
  1626. return $more . RcOtherParameters();
  1627. }
  1628. sub GetFilterForm {
  1629. my $form = $q->strong(T('Filters'));
  1630. $form .= $q->input({-type=>'hidden', -name=>'action', -value=>'rc'});
  1631. $form .= $q->input({-type=>'hidden', -name=>'all', -value=>1}) if (GetParam('all', $ShowAll));
  1632. $form .= $q->input({-type=>'hidden', -name=>'showedit', -value=>1}) if (GetParam('showedit', $ShowEdits));
  1633. if (GetParam('days', $RcDefault) != $RcDefault) {
  1634. $form .= $q->input({-type=>'hidden', -name=>'days', -value=>GetParam('days', $RcDefault)});
  1635. }
  1636. my $table = '';
  1637. foreach my $h (['match' => T('Title:')],
  1638. ['rcfilteronly' => T('Title and Body:')],
  1639. ['rcuseronly' => T('Username:')], ['rchostonly' => T('Host:')],
  1640. ['followup' => T('Follow up to:')]) {
  1641. $table .= $q->Tr($q->td($q->label({-for=>$h->[0]}, $h->[1])),
  1642. $q->td($q->textfield(-name=>$h->[0], -id=>$h->[0], -size=>20)));
  1643. }
  1644. if (%Languages) {
  1645. $table .= $q->Tr($q->td($q->label({-for=>'rclang'}, T('Language:')))
  1646. . $q->td($q->textfield(-name=>'lang', -id=>'rclang', -size=>10,
  1647. -default=>GetParam('lang', ''))));
  1648. }
  1649. return GetFormStart(undef, 'get', 'filter') . $q->p($form) . $q->table($table)
  1650. . $q->p($q->submit('dofilter', T('Go!'))) . $q->end_form;
  1651. }
  1652. sub RcHtml {
  1653. my ($html, $inlist) = ('', 0);
  1654. # Optimize param fetches and translations out of main loop
  1655. my $all = GetParam('all', $ShowAll);
  1656. my $admin = UserIsAdmin();
  1657. my $rollback_was_possible = 0;
  1658. my $printDailyTear = sub {
  1659. my $date = shift;
  1660. if ($inlist) {
  1661. $html .= '</ul>';
  1662. $inlist = 0;
  1663. }
  1664. $html .= $q->p($q->strong($date));
  1665. if (not $inlist) {
  1666. $html .= '<ul>';
  1667. $inlist = 1;
  1668. }
  1669. };
  1670. my $printRCLine = sub {
  1671. my($id, $ts, $host, $username, $summary, $minor, $revision,
  1672. $languages, $cluster, $last) = @_;
  1673. my $all_revision = $last ? undef : $revision; # no revision for the last one
  1674. $host = QuoteHtml($host);
  1675. my $author = GetAuthorLink($username, $host);
  1676. my $sum = $summary ? $q->span({class=>'dash'}, ' &#8211; ')
  1677. . $q->strong(QuoteHtml($summary)) : '';
  1678. my $edit = $minor ? $q->em({class=>'type'}, T('(minor)')) : '';
  1679. my $lang = @{$languages}
  1680. ? $q->span({class=>'lang'}, '[' . join(', ', @{$languages}) . ']') : '';
  1681. my ($pagelink, $history, $diff, $rollback) = ('', '', '', '');
  1682. if ($all) {
  1683. $pagelink = GetOldPageLink('browse', $id, $all_revision, $id, $cluster);
  1684. my $rollback_is_possible = RollbackPossible($ts);
  1685. if ($admin and ($rollback_is_possible or $rollback_was_possible)) {
  1686. $rollback = $q->submit("rollback-$ts", T('rollback'));
  1687. $rollback_was_possible = $rollback_is_possible;
  1688. } else {
  1689. $rollback_was_possible = 0;
  1690. }
  1691. } elsif ($cluster) {
  1692. $pagelink = GetOldPageLink('browse', $id, $revision, $id, $cluster);
  1693. } else {
  1694. $pagelink = GetPageLink($id, $cluster);
  1695. $history = '(' . GetHistoryLink($id, T('history')) . ')';
  1696. }
  1697. if ($cluster and $PageCluster) {
  1698. $diff .= GetPageLink($PageCluster) . ':';
  1699. } elsif ($UseDiff and GetParam('diffrclink', 1)) {
  1700. if ($revision == 1) {
  1701. $diff .= '(' . $q->span({-class=>'new'}, T('new')) . ')';
  1702. } elsif ($all) {
  1703. $diff .= '(' . ScriptLinkDiff(2, $id, T('diff'), $all_revision) .')';
  1704. } else {
  1705. $diff .= '(' . ScriptLinkDiff($minor ? 2 : 1, $id, T('diff')) . ')';
  1706. }
  1707. }
  1708. $html .= $q->li($q->span({-class=>'time'}, CalcTime($ts)), $diff, $history,
  1709. $rollback, $pagelink, T(' . . . .'), $author, $sum, $lang,
  1710. $edit);
  1711. };
  1712. ProcessRcLines($printDailyTear, $printRCLine);
  1713. $html .= '</ul>' if $inlist;
  1714. $html .= $q->p({-class=>'more'}, ScriptLink(RcPreviousAction(), T('More...'), 'more'));
  1715. return GetFormStart(undef, 'get', 'rc') . $html . $q->end_form;
  1716. }
  1717. sub PrintRcHtml { # to append RC to existing page, or action=rc directly
  1718. my ($id, $standalone) = @_;
  1719. my $rc = ($id eq $RCName or $id eq T($RCName) or T($id) eq $RCName);
  1720. if ($standalone) {
  1721. print GetHeader('', $rc ? NormalToFree($id) : Ts('All changes for %s', NormalToFree($id)));
  1722. }
  1723. if ($standalone or $rc or GetParam('rcclusteronly', '')) {
  1724. print $q->start_div({-class=>'rc'});
  1725. print $q->hr() unless $standalone or GetParam('embed', $EmbedWiki);
  1726. print RcHeader() . RcHtml() . GetFilterForm() . $q->end_div();
  1727. }
  1728. PrintFooter($id) if $standalone;
  1729. }
  1730. sub RcTextItem {
  1731. my ($name, $value) = @_;
  1732. $value = UnquoteHtml($value);
  1733. $value =~ s/\n+$//;
  1734. $value =~ s/\n+/\n /g;
  1735. return $value ? $name . ': ' . $value . "\n" : '';
  1736. }
  1737. sub RcTextRevision {
  1738. my($id, $ts, $host, $username, $summary, $minor, $revision,
  1739. $languages, $cluster, $last) = @_;
  1740. my $link = $ScriptName
  1741. . (GetParam('all', $ShowAll) && ! $last
  1742. ? '?' . GetPageParameters('browse', $id, $revision, $cluster, $last)
  1743. : ($UsePathInfo ? '/' : '?') . UrlEncode($id));
  1744. $summary = GetPageContent($id) if GetParam('full', 0);
  1745. print "\n", RcTextItem('title', NormalToFree($id)),
  1746. RcTextItem('description', $summary),
  1747. RcTextItem('generator', GetAuthor($username, $host)),
  1748. RcTextItem('language', join(', ', @{$languages})), RcTextItem('link', $link),
  1749. RcTextItem('last-modified', TimeToW3($ts)),
  1750. RcTextItem('revision', $revision),
  1751. RcTextItem('minor', $minor);
  1752. }
  1753. sub PrintRcText { # print text rss header and call ProcessRcLines
  1754. local $RecentLink = 0;
  1755. print RcTextItem('title', $SiteName),
  1756. RcTextItem('description', $SiteDescription), RcTextItem('link', $ScriptName),
  1757. RcTextItem('generator', 'Oddmuse'), RcTextItem('rights', $RssRights);
  1758. ProcessRcLines(sub {}, \&RcTextRevision);
  1759. }
  1760. sub GetRcRss {
  1761. my $date = TimeToRFC822($LastUpdate);
  1762. my @excluded = ();
  1763. if (GetParam("exclude", 1)) {
  1764. foreach (split(/\n/, GetPageContent($RssExclude))) {
  1765. if (/^ ([^ ]+)[ \t]*$/) { # only read lines with one word after one space
  1766. push(@excluded, $1);
  1767. }
  1768. }
  1769. }
  1770. my $rss = qq{<?xml version="1.0" encoding="UTF-8"?>\n};
  1771. if ($RssStyleSheet =~ /\.(xslt?|xml)$/) {
  1772. $rss .= qq{<?xml-stylesheet type="text/xml" href="$RssStyleSheet" ?>\n};
  1773. } elsif ($RssStyleSheet) {
  1774. $rss .= qq{<?xml-stylesheet type="text/css" href="$RssStyleSheet" ?>\n};
  1775. }
  1776. $rss .= qq{<rss version="2.0"
  1777. xmlns:wiki="http://purl.org/rss/1.0/modules/wiki/"
  1778. xmlns:dc="http://purl.org/dc/elements/1.1/"
  1779. xmlns:cc="http://web.resource.org/cc/"
  1780. xmlns:atom="http://www.w3.org/2005/Atom">
  1781. <channel>
  1782. <docs>http://blogs.law.harvard.edu/tech/rss</docs>
  1783. };
  1784. my $title = QuoteHtml($SiteName) . ': ' . GetParam('title', QuoteHtml(NormalToFree($HomePage)));
  1785. $rss .= "<title>$title</title>\n";
  1786. $rss .= "<link>$ScriptName?" . RcSelfAction() . "</link>\n";
  1787. $rss .= qq{<atom:link href="$ScriptName?} . RcSelfAction() . qq{" rel="self" type="application/rss+xml" />\n};
  1788. $rss .= qq{<atom:link href="$ScriptName?} . RcPreviousAction() . qq{" rel="previous" type="application/rss+xml" />\n};
  1789. $rss .= qq{<atom:link href="$ScriptName?} . RcLastAction() . qq{" rel="last" type="application/rss+xml" />\n};
  1790. if ($SiteDescription) {
  1791. $rss .= "<description>" . QuoteHtml($SiteDescription) . "</description>\n"
  1792. }
  1793. $rss .= "<pubDate>$date</pubDate>\n";
  1794. $rss .= "<lastBuildDate>$date</lastBuildDate>\n";
  1795. $rss .= "<generator>Oddmuse</generator>\n";
  1796. $rss .= "<copyright>$RssRights</copyright>\n" if $RssRights;
  1797. if ($RssLicense) {
  1798. $rss .= join('', map {"<cc:license>" . QuoteHtml($_) . "</cc:license>\n"}
  1799. (ref $RssLicense eq 'ARRAY' ? @$RssLicense : $RssLicense))
  1800. }
  1801. $rss .= "<wiki:interwiki>$InterWikiMoniker</wiki:interwiki>\n" if $InterWikiMoniker;
  1802. if ($RssImageUrl) {
  1803. $rss .= "<image>\n";
  1804. $rss .= "<url>$RssImageUrl</url>\n";
  1805. $rss .= "<title>$title</title>\n"; # the same as the channel
  1806. $rss .= "<link>$ScriptName?" . RcSelfAction() . "</link>\n"; # the same as the channel
  1807. $rss .= "</image>\n";
  1808. }
  1809. my $limit = GetParam("rsslimit", 15); # Only take the first 15 entries
  1810. my $count = 0;
  1811. ProcessRcLines(sub {}, sub {
  1812. my $id = shift;
  1813. return if grep { $id =~ /$_/ } @excluded or ($limit ne 'all' and $count++ >= $limit);
  1814. $rss .= "\n" . RssItem($id, @_);
  1815. });
  1816. $rss .= "</channel>\n</rss>\n";
  1817. return $rss;
  1818. }
  1819. sub RssItem {
  1820. my ($id, $ts, $host, $username, $summary, $minor, $revision,
  1821. $languages, $cluster, $last) = @_;
  1822. my $name = ItemName($id);
  1823. if (GetParam('full', 0)) { # full page means summary is not shown
  1824. $summary = PageHtml($id, 50 * 1024, T('This page is too big to send over RSS.'));
  1825. } else {
  1826. $summary = QuoteHtml($summary); # page summary must be quoted
  1827. }
  1828. my $date = TimeToRFC822($ts);
  1829. $username = QuoteHtml($username);
  1830. my $rss = "<item>\n";
  1831. $rss .= "<title>$name</title>\n";
  1832. my $link = ScriptUrl(GetParam('all', $cluster)
  1833. ? GetPageParameters('browse', $id, $revision, $cluster, $last)
  1834. : UrlEncode($id));
  1835. $rss .= "<link>$link</link>\n<guid>$link</guid>\n";
  1836. $rss .= "<description>" . QuoteHtml($summary) . "</description>\n" if $summary;
  1837. $rss .= "<pubDate>" . $date . "</pubDate>\n";
  1838. $rss .= "<comments>" . ScriptUrl($CommentsPrefix . UrlEncode($id))
  1839. . "</comments>\n" if $CommentsPattern and $id !~ /$CommentsPattern/;
  1840. $rss .= "<dc:contributor>" . $username . "</dc:contributor>\n" if $username;
  1841. $rss .= "<wiki:status>" . (1 == $revision ? 'new' : 'updated') . "</wiki:status>\n";
  1842. $rss .= "<wiki:importance>" . ($minor ? 'minor' : 'major') . "</wiki:importance>\n";
  1843. $rss .= "<wiki:version>" . $revision . "</wiki:version>\n";
  1844. $rss .= "<wiki:history>" . ScriptUrl("action=history;id=" . UrlEncode($id))
  1845. . "</wiki:history>\n";
  1846. $rss .= "<wiki:diff>" . ScriptUrl("action=browse;diff=1;id=" . UrlEncode($id))
  1847. . "</wiki:diff>\n" if $UseDiff and GetParam('diffrclink', 1);
  1848. return $rss . "</item>\n";
  1849. }
  1850. sub DoRss {
  1851. print GetHttpHeader('application/xml');
  1852. print GetRcRss();
  1853. }
  1854. sub DoHistory {
  1855. my $id = shift;
  1856. ValidIdOrDie($id);
  1857. OpenPage($id);
  1858. if (GetParam('raw', 0)) {
  1859. DoRawHistory($id);
  1860. } else {
  1861. DoHtmlHistory($id);
  1862. }
  1863. }
  1864. sub DoRawHistory {
  1865. my ($id) = @_;
  1866. print GetHttpHeader('text/plain'),
  1867. RcTextItem('title', Ts('History of %s', NormalToFree($OpenPageName))),
  1868. RcTextItem('date', TimeToText($Now)),
  1869. RcTextItem('link', ScriptUrl("action=history;id=$OpenPageName;raw=1")),
  1870. RcTextItem('generator', 'Oddmuse');
  1871. SetParam('all', 1);
  1872. my @languages = split(/,/, $Page{languages});
  1873. RcTextRevision($id, $Page{ts}, $Page{host}, $Page{username}, $Page{summary},
  1874. $Page{minor}, $Page{revision}, \@languages, undef, 1);
  1875. foreach my $revision (GetKeepRevisions($OpenPageName)) {
  1876. my $keep = GetKeptRevision($revision);
  1877. @languages = split(/,/, $keep->{languages});
  1878. RcTextRevision($id, $keep->{ts}, $keep->{host}, $keep->{username},
  1879. $keep->{summary}, $keep->{minor}, $keep->{revision}, \@languages);
  1880. }
  1881. }
  1882. sub DoHtmlHistory {
  1883. my ($id) = @_;
  1884. print GetHeader('', Ts('History of %s', NormalToFree($id)));
  1885. my $row = 0;
  1886. my $rollback = UserCanEdit($id, 0) && (GetParam('username', '') or UserIsEditor());
  1887. my $date = CalcDay($Page{ts});
  1888. my @html = (GetFormStart(undef, 'get', 'history'));
  1889. push(@html, $q->p({-class => 'documentation'}, T('Using the 「rollback」 button on this page will reset the page to that particular point in time, undoing any later changes to this page.'))) if $rollback;
  1890. push(@html, $q->p(# don't use $q->hidden here!
  1891. $q->input({-type=>'hidden', -name=>'action', -value=>'browse'}),
  1892. $q->input({-type=>'hidden', -name=>'diff', -value=>'1'}),
  1893. $q->input({-type=>'hidden', -name=>'id', -value=>$id})));
  1894. # list of rows with revisions, starting with current revision
  1895. push(@html, $q->p($q->submit({-name=>T('Compare')}))) if $UseDiff;
  1896. my @rows = (GetHistoryLine($id, \%Page, $row++, $rollback, $date, 1));
  1897. foreach my $revision (GetKeepRevisions($OpenPageName)) {
  1898. my $keep = GetKeptRevision($revision);
  1899. my $new = CalcDay($keep->{ts});
  1900. push(@rows, GetHistoryLine($id, $keep, $row++, $rollback, $new, $new ne $date));
  1901. $date = $new;
  1902. }
  1903. # if we can use diff, add radio-buttons and compare buttons if $UseDiff
  1904. if ($UseDiff) {
  1905. push(@html, $q->table({-class=>'history'}, @rows),
  1906. $q->p($q->submit({-name=>T('Compare')})), $q->end_form());
  1907. } else {
  1908. push(@html, @rows);
  1909. }
  1910. if ($KeepDays and $rollback and $Page{revision}) {
  1911. push(@html, $q->p(ScriptLink('title=' . UrlEncode($id) . ';text='
  1912. . UrlEncode($DeletedPage) . ';summary='
  1913. . UrlEncode(T('Deleted')),
  1914. T('Mark this page for deletion'))));
  1915. }
  1916. print $q->div({-class=>'content history'}, @html);
  1917. PrintFooter($id, 'history');
  1918. }
  1919. sub GetHistoryLine {
  1920. my ($id, $dataref, $row, $rollback, $date, $newday) = @_;
  1921. my %data = %$dataref;
  1922. my $revision = $data{revision};
  1923. return $q->p(T('No other revisions available')) unless $revision;
  1924. my $html = CalcTime($data{ts});
  1925. if ($row == 0) { # current revision
  1926. $html .= ' (' . T('current') . ')' if $rollback;
  1927. $html .= ' ' . GetPageLink($id, Ts('Revision %s', $revision));
  1928. } else {
  1929. $html .= ' ' . $q->submit("rollback-$data{ts}", T('rollback')) if $rollback;
  1930. $html .= ' ' . GetOldPageLink('browse', $id, $revision,
  1931. Ts('Revision %s', $revision));
  1932. }
  1933. $html .= T(' . . . .') . ' ' . GetAuthorLink($data{username});
  1934. $html .= $q->span({class=>'dash'}, ' &#8211; ')
  1935. . $q->strong(QuoteHtml($data{summary})) if $data{summary};
  1936. $html .= ' ' . $q->em({class=>'type'}, T('(minor)')) . ' ' if $data{minor};
  1937. if ($UseDiff) {
  1938. my %attr1 = (-type=>'radio', -name=>'diffrevision', -value=>$revision);
  1939. $attr1{-checked} = 'checked' if $row == 1;
  1940. my %attr2 = (-type=>'radio', -name=>'revision', -value=> $row ? $revision : '');
  1941. $attr2{-checked} = 'checked' if $row == 0; # first row is special
  1942. $html = $q->Tr($q->td($q->input(\%attr1)), $q->td($q->input(\%attr2)), $q->td($html));
  1943. $html = $q->Tr($q->td({-colspan=>3}, $q->strong($date))) . $html if $newday;
  1944. } else {
  1945. $html .= $q->br();
  1946. $html = $q->strong($date) . $q->br() . $html if $newday;
  1947. }
  1948. return $html;
  1949. }
  1950. sub DoContributors {
  1951. my $id = shift;
  1952. SetParam('rcidonly', $id);
  1953. SetParam('all', 1);
  1954. print GetHeader('', Ts('Contributors to %s', NormalToFree($id || $SiteName)));
  1955. my %contrib = ();
  1956. for my $line (GetRcLines(1)) {
  1957. my ($ts, $pagename, $minor, $summary, $host, $username) = @$line;
  1958. $contrib{$username}++ if $username;
  1959. }
  1960. print $q->div({-class=>'content contrib'},
  1961. $q->p(map { GetPageLink($_) } sort(keys %contrib)));
  1962. PrintFooter();
  1963. }
  1964. sub RollbackPossible {
  1965. my $ts = shift; # there can be no rollback to the most recent change(s) made (1s resolution!)
  1966. return $ts != $LastUpdate && (!$KeepDays || ($Now - $ts) < $KeepDays * 86400); # 24*60*60
  1967. }
  1968. sub DoRollback {
  1969. my $page = shift;
  1970. my $to = GetParam('to', 0);
  1971. ReportError(T('Missing target for rollback.'), '400 BAD REQUEST') unless $to;
  1972. ReportError(T('Target for rollback is too far back.'), '400 BAD REQUEST') unless $page or RollbackPossible($to);
  1973. ReportError(T('A username is required for ordinary users.'), '403 FORBIDDEN') unless GetParam('username', '') or UserIsEditor();
  1974. my @ids = ();
  1975. if (not $page) { # cannot just use list length because of ('')
  1976. return unless UserIsAdminOrError(); # only admins can do mass changes
  1977. SetParam('showedit', 1); # make GetRcLines return minor edits as well
  1978. SetParam('all', 1); # prevent LatestChanges from interfering
  1979. SetParam('rollback', 1); # prevent StripRollbacks from interfering
  1980. my %ids = map { my ($ts, $id) = @$_; $id => 1; } # make unique via hash
  1981. GetRcLines($to); # list all the pages edited since $to
  1982. @ids = keys %ids;
  1983. } else {
  1984. @ids = ($page);
  1985. }
  1986. RequestLockOrError();
  1987. print GetHeader('', T('Rolling back changes')),
  1988. $q->start_div({-class=>'content rollback'}), $q->start_p();
  1989. foreach my $id (@ids) {
  1990. OpenPage($id);
  1991. my ($text, $minor, $ts) = GetTextAtTime($to);
  1992. if ($Page{text} eq $text) {
  1993. print T("The two revisions are the same."), $q->br() if $page; # no message when doing mass revert
  1994. } elsif (not UserCanEdit($id, 1)) {
  1995. print Ts('Editing not allowed: %s is read-only.', $id), $q->br();
  1996. } elsif (not UserIsEditor() and my $rule = BannedContent($text)) {
  1997. print Ts('Rollback of %s would restore banned content.', $id), $rule, $q->br();
  1998. } else {
  1999. Save($id, $text, Ts('Rollback to %s', TimeToText($to)), $minor, ($Page{host} ne $q->remote_addr()));
  2000. print Ts('%s rolled back', GetPageLink($id)), ($ts ? ' ' . Ts('to %s', TimeToText($to)) : ''), $q->br();
  2001. }
  2002. }
  2003. WriteRcLog('[[rollback]]', $page, $to); # leave marker
  2004. print $q->end_p() . $q->end_div();
  2005. ReleaseLock();
  2006. PrintFooter($page, 'edit');
  2007. }
  2008. sub DoAdminPage {
  2009. my ($id, @rest) = @_;
  2010. my @menu = ();
  2011. push(@menu, ScriptLink('action=index', T('Index of all pages'), 'index')) if $Action{index};
  2012. push(@menu, ScriptLink('action=version', T('Wiki Version'), 'version')) if $Action{version};
  2013. push(@menu, ScriptLink('action=password', T('Password'), 'password')) if $Action{password};
  2014. push(@menu, ScriptLink('action=maintain', T('Run maintenance'), 'maintain')) if $Action{maintain};
  2015. my @locks;
  2016. for my $pattern (@KnownLocks) {
  2017. for my $name (Glob($pattern)) {
  2018. if (IsDir($LockDir . $name)) {
  2019. push(@locks, $name);
  2020. }
  2021. }
  2022. }
  2023. if (@locks and $Action{unlock}) {
  2024. push(@menu, ScriptLink('action=unlock', T('Unlock Wiki'), 'unlock') . ' (' . join(', ', @locks) . ')');
  2025. };
  2026. if (UserIsAdmin()) {
  2027. if ($Action{editlock}) {
  2028. if (IsFile("$DataDir/noedit")) {
  2029. push(@menu, ScriptLink('action=editlock;set=0', T('Unlock site'), 'editlock 0'));
  2030. } else {
  2031. push(@menu, ScriptLink('action=editlock;set=1', T('Lock site'), 'editlock 1'));
  2032. }
  2033. }
  2034. if ($id and $Action{pagelock}) {
  2035. my $title = NormalToFree($id);
  2036. if (IsFile(GetLockedPageFile($id))) {
  2037. push(@menu, ScriptLink('action=pagelock;set=0;id=' . UrlEncode($id),
  2038. Ts('Unlock %s', $title), 'pagelock 0'));
  2039. } else {
  2040. push(@menu, ScriptLink('action=pagelock;set=1;id=' . UrlEncode($id),
  2041. Ts('Lock %s', $title), 'pagelock 1'));
  2042. }
  2043. }
  2044. push(@menu, ScriptLink('action=clear', T('Clear Cache'), 'clear')) if $Action{clear};
  2045. }
  2046. foreach my $sub (@MyAdminCode) {
  2047. $sub->($id, \@menu, \@rest);
  2048. $Message .= $q->p($@) if $@; # since this happens before GetHeader is called, the message will be shown
  2049. }
  2050. print GetHeader('', T('Administration')),
  2051. $q->div({-class=>'content admin'}, $q->p(T('Actions:')), $q->ul($q->li(\@menu)),
  2052. $q->p(T('Important pages:')) . $q->ul(map { $q->li(GetPageOrEditLink($_, NormalToFree($_))) if $_;
  2053. } sort keys %AdminPages),
  2054. $q->p(Ts('To mark a page for deletion, put <strong>%s</strong> on the first line.',
  2055. $DeletedPage)), @rest);
  2056. PrintFooter();
  2057. }
  2058. sub GetPageParameters {
  2059. my ($action, $id, $revision, $cluster, $last) = @_;
  2060. $id = FreeToNormal($id);
  2061. my $link = "action=$action;id=" . UrlEncode($id);
  2062. $link .= ";revision=$revision" if $revision and not $last;
  2063. $link .= ';rcclusteronly=' . UrlEncode($cluster) if $cluster;
  2064. return $link;
  2065. }
  2066. sub GetOldPageLink {
  2067. my ($action, $id, $revision, $name, $cluster, $last) = @_;
  2068. return ScriptLink(GetPageParameters($action, $id, $revision, $cluster, $last),
  2069. NormalToFree($name), 'revision');
  2070. }
  2071. sub GetSearchLink {
  2072. my ($text, $class, $name, $title) = @_;
  2073. my $id = UrlEncode(QuoteRegexp('"' . $text . '"'));
  2074. $name = UrlEncode($name);
  2075. $text = NormalToFree($text);
  2076. $id =~ s/_/+/g; # Search for url-escaped spaces
  2077. return ScriptLink('search=' . $id, $text, $class, $name, $title);
  2078. }
  2079. sub ScriptLinkDiff {
  2080. my ($diff, $id, $text, $new, $old) = @_;
  2081. my $action = 'action=browse;diff=' . $diff . ';id=' . UrlEncode($id);
  2082. $action .= ";diffrevision=$old" if $old;
  2083. $action .= ";revision=$new" if $new;
  2084. return ScriptLink($action, $text, 'diff');
  2085. }
  2086. sub Code {
  2087. my ($str) = @_;
  2088. my $num = unpack("L",B::hash($str)); # 32-bit integer
  2089. my $code = sprintf("%o", $num); # octal is 0-7
  2090. return substr($code, 0, 4); # four numbers
  2091. }
  2092. sub ColorCode {
  2093. my $code = Code(@_);
  2094. my @indexes = split(//, $code); # four numbers
  2095. my @colors = qw/red orange yellow green blue indigo violet white/;
  2096. return $q->span({-class => 'ip-code', -title => T('Anonymous')},
  2097. join('', map { $q->span({-class => $colors[$_]}, $_) }
  2098. @indexes));
  2099. }
  2100. sub GetAuthor {
  2101. my ($username, $host) = @_;
  2102. return $username if $username;
  2103. return T('Anonymous') if $host eq 'Anonymous';
  2104. return Code($host);
  2105. }
  2106. sub GetAuthorLink {
  2107. my ($username, $host) = @_;
  2108. $username = FreeToNormal($username);
  2109. my $name = NormalToFree($username);
  2110. if (ValidId($username) ne '') { # ValidId() returns error string
  2111. $username = ''; # Just pretend it isn't there.
  2112. }
  2113. if ($username and $RecentLink) {
  2114. return ScriptLink(UrlEncode($username), $name, 'author');
  2115. } elsif ($username) {
  2116. return $q->span({-class=>'author'}, $name);
  2117. }
  2118. return T('Anonymous') if $host eq 'Anonymous';
  2119. return ColorCode($host);
  2120. }
  2121. sub GetHistoryLink {
  2122. my ($id, $text) = @_;
  2123. my $action = 'action=history;id=' . UrlEncode(FreeToNormal($id));
  2124. return ScriptLink($action, $text, 'history');
  2125. }
  2126. sub GetRCLink {
  2127. my ($id, $text) = @_;
  2128. return ScriptLink('action=rc;all=1;from=1;showedit=1;rcidonly='
  2129. . UrlEncode(FreeToNormal($id)), $text, 'rc');
  2130. }
  2131. sub GetHeader {
  2132. my ($id, $title, $oldId, $nocache, $status) = @_;
  2133. my $embed = GetParam('embed', $EmbedWiki);
  2134. my $result = GetHttpHeader('text/html', $nocache, $status);
  2135. if ($oldId) {
  2136. $Message .= $q->p('(' . Ts('redirected from %s', GetEditLink($oldId, $oldId)) . ')');
  2137. }
  2138. $result .= GetHtmlHeader(Ts('%s:', $SiteName) . ' ' . UnWiki($title), $id);
  2139. if ($embed) {
  2140. $result .= $q->div({-class=>'header'}, $q->div({-class=>'message'}, $Message)) if $Message;
  2141. return $result;
  2142. }
  2143. $result .= GetHeaderDiv($id, $title, $oldId, $embed);
  2144. return $result . $q->start_div({-class=>'wrapper'});
  2145. }
  2146. sub GetHeaderDiv {
  2147. my ($id, $title, $oldId, $embed) = @_;
  2148. my $result .= '<header>';
  2149. if (not $embed and $LogoUrl) {
  2150. my $url = $IndexHash{$LogoUrl} ? GetDownloadLink($LogoUrl, 2) : $LogoUrl;
  2151. $result .= ScriptLink(UrlEncode($HomePage), $q->img({-src=>$url, -alt=>T('[Home]'), -class=>'logo'}), 'logo');
  2152. }
  2153. $result .= '<nav>';
  2154. if (GetParam('toplinkbar', $TopLinkBar) != 2) {
  2155. $result .= GetGotoBar($id);
  2156. if (%SpecialDays) {
  2157. my ($sec, $min, $hour, $mday, $mon, $year) = gmtime($Now);
  2158. if ($SpecialDays{($mon + 1) . '-' . $mday}) {
  2159. $result .= $q->br() . $q->span({-class=>'specialdays'},
  2160. $SpecialDays{($mon + 1) . '-' . $mday});
  2161. }
  2162. }
  2163. }
  2164. $result .= GetSearchForm() if GetParam('topsearchform', $TopSearchForm) != 2;
  2165. $result .= '</nav>';
  2166. $result .= $q->div({-class=>'message'}, $Message) if $Message;
  2167. $result .= GetHeaderTitle($id, $title, $oldId);
  2168. $result .= '</header>';
  2169. return $result;
  2170. }
  2171. sub GetHeaderTitle {
  2172. my ($id, $title, $oldId) = @_;
  2173. return $q->h1($title) if $id eq '';
  2174. return $q->h1(GetSearchLink($id, '', '', T('Click to search for references to this page')));
  2175. }
  2176. sub GetHttpHeader {
  2177. return if $HeaderIsPrinted; # When calling ReportError, we don't know whether HTTP headers have
  2178. $HeaderIsPrinted = 1; # already been printed. We want them printed just once.
  2179. my ($type, $ts, $status, $encoding) = @_;
  2180. $q->charset($type =~ m!^(text/|application/xml)! ? 'utf-8' : ''); # text/plain, text/html, application/xml: UTF-8
  2181. my %headers = (-cache_control=>($UseCache < 0 ? 'no-cache' : 'max-age=10'));
  2182. # Set $ts when serving raw content that cannot be modified by cookie
  2183. # parameters; or 'nocache'; or undef. If you provide a $ts, the last-modified
  2184. # header generated will by used by HTTP/1.0 clients. If you provide no $ts,
  2185. # the etag header generated will be used by HTTP/1.1 clients. In this
  2186. # situation, cookie parameters can influence the look of the page and we
  2187. # cannot rely on $LastUpdate. HTTP/1.0 clients will ignore etags. See RFC 2616
  2188. # section 13.3.4.
  2189. if (GetParam('cache', $UseCache) >= 2 and $ts ne 'nocache') {
  2190. $headers{'-last-modified'} = TimeToRFC822($ts) if $ts;
  2191. $headers{-etag} = PageEtag();
  2192. }
  2193. $headers{-type} = GetParam('mime-type', $type);
  2194. $headers{-status} = $status if $status;
  2195. $headers{-Content_Encoding} = $encoding if $encoding;
  2196. my $cookie = Cookie();
  2197. $headers{-cookie} = $cookie if $cookie;
  2198. if ($q->request_method() eq 'HEAD') {
  2199. print $q->header(%headers), "\n\n"; # add newlines for FCGI because of exit()
  2200. exit; # total shortcut -- HEAD never expects anything other than the header!
  2201. }
  2202. return $q->header(%headers);
  2203. }
  2204. sub CookieData {
  2205. my ($changed, %params);
  2206. foreach my $key (keys %CookieParameters) {
  2207. my $default = $CookieParameters{$key};
  2208. my $value = GetParam($key, $default);
  2209. $params{$key} = $value if $value ne $default;
  2210. # The cookie is considered to have changed under the following
  2211. # condition: If the value was already set, and the new value is
  2212. # not the same as the old value, or if there was no old value, and
  2213. # the new value is not the default.
  2214. my $change = (defined $OldCookie{$key} ? ($value ne $OldCookie{$key}) : ($value ne $default));
  2215. $changed = 1 if $change; # note if any parameter changed and needs storing
  2216. }
  2217. return $changed, %params;
  2218. }
  2219. sub Cookie {
  2220. my ($changed, %params) = CookieData(); # params are URL encoded
  2221. if ($changed) {
  2222. my $cookie = join(UrlEncode($FS), %params); # no CTL in field values
  2223. return $q->cookie(-name=>$CookieName, -value=>$cookie, -expires=>'+2y', secure=>$ENV{'HTTPS'}, httponly=>1);
  2224. }
  2225. return '';
  2226. }
  2227. sub GetHtmlHeader { # always HTML!
  2228. my ($title, $id) = @_;
  2229. my $edit_link = $id ? '<link rel="alternate" type="application/wiki" title="'
  2230. . T('Edit this page') . '" href="' . ScriptUrl('action=edit;id=' . UrlEncode($id)) . '" />' : '';
  2231. my $theme = GetParam('theme', 'default');
  2232. return $DocumentHeader
  2233. . $q->head($q->title($title) . $edit_link
  2234. . GetCss() . GetRobots() . GetFeeds() . $HtmlHeaders
  2235. . '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />')
  2236. . qq{<body class="$theme" lang="$CurrentLanguage">};
  2237. }
  2238. sub GetRobots { # NOINDEX for non-browse pages.
  2239. if (GetParam('action', 'browse') eq 'browse' and not GetParam('revision', '')) {
  2240. return '<meta name="robots" content="INDEX,FOLLOW" />';
  2241. } else {
  2242. return '<meta name="robots" content="NOINDEX,FOLLOW" />';
  2243. }
  2244. }
  2245. sub GetFeeds { # default for $HtmlHeaders
  2246. my $html = '<link rel="alternate" type="application/rss+xml" title="'
  2247. . QuoteHtml($SiteName) . '" href="' . $ScriptName . '?action=rss" />';
  2248. my $id = GetId(); # runs during Init, not during DoBrowseRequest
  2249. $html .= '<link rel="alternate" type="application/rss+xml" title="'
  2250. . QuoteHtml("$SiteName: $id") . '" href="' . $ScriptName
  2251. . '?action=rss;rcidonly=' . UrlEncode(FreeToNormal($id)) . '" />' if $id;
  2252. my $username = GetParam('username', '');
  2253. $html .= '<link rel="alternate" type="application/rss+xml" '
  2254. . 'title="Follow-ups for ' . NormalToFree($username) . '" '
  2255. . 'href="' . ScriptUrl('action=rss;followup=' . UrlEncode($username))
  2256. . '" />' if $username;
  2257. return $html;
  2258. }
  2259. sub GetCss { # prevent javascript injection
  2260. my @css = map { my $x = $_; $x =~ s/\".*//; $x; } split(/\s+/, GetParam('css', ''));
  2261. push (@css, ref $StyleSheet ? @$StyleSheet : $StyleSheet) if $StyleSheet and not @css;
  2262. if ($IndexHash{$StyleSheetPage} and not @css) {
  2263. push (@css, "$ScriptName?action=browse;id=" . UrlEncode($StyleSheetPage) . ";raw=1;mime-type=text/css")
  2264. }
  2265. push (@css, 'https://oddmuse.org/default.css') unless @css;
  2266. return join('', map { qq(<link type="text/css" rel="stylesheet" href="$_" />) } @css);
  2267. }
  2268. sub PrintPageContent {
  2269. my ($text, $revision, $comment) = @_;
  2270. print $q->start_div({-class=>'content browse', -lang=>GetLanguage($text)});
  2271. # This is a lot like PrintPageHtml except that it also works for older revisions
  2272. if ($revision eq '' and $Page{blocks} and GetParam('cache', $UseCache) > 0) {
  2273. PrintCache();
  2274. } else {
  2275. my $savecache = ($Page{revision} > 0 and $revision eq ''); # new page not cached
  2276. PrintWikiToHTML($text, $savecache, $revision); # unlocked, with anchors, unlocked
  2277. }
  2278. if ($comment) {
  2279. print $q->start_div({-class=>'preview'}), $q->hr();
  2280. print $q->h2(T('Preview:'));
  2281. # no caching, current revision, unlocked
  2282. PrintWikiToHTML(AddComment('', $comment));
  2283. print $q->hr(), $q->h2(T('Preview only, not yet saved')), $q->end_div();
  2284. }
  2285. print $q->end_div();
  2286. }
  2287. sub PrintFooter {
  2288. my ($id, $rev, $comment, $page) = @_;
  2289. if (GetParam('embed', $EmbedWiki)) {
  2290. print $q->end_html, "\n";
  2291. return;
  2292. }
  2293. PrintMyContent($id) if defined(&PrintMyContent);
  2294. foreach my $sub (@MyFooters) {
  2295. print $sub->(@_);
  2296. }
  2297. print $q->end_html, "\n";
  2298. }
  2299. sub WrapperEnd { # called via @MyFooters
  2300. return $q->start_div({-class=>'wrapper close'}) . $q->end_div() . $q->end_div(); # closes content
  2301. }
  2302. sub DefaultFooter { # called via @MyFooters
  2303. my ($id, $rev, $comment, $page) = @_;
  2304. my $html = $q->hr();
  2305. $html .= GetGotoBar($id) if GetParam('toplinkbar', $TopLinkBar) != 1;
  2306. $html .= GetFooterLinks($id, $rev);
  2307. $html .= GetFooterTimestamp($id, $rev, $page);
  2308. $html .= GetSearchForm() if GetParam('topsearchform', $TopSearchForm) != 1;
  2309. if ($DataDir =~ m|/tmp/|) {
  2310. $html .= $q->p($q->strong(T('Warning') . ': ')
  2311. . Ts('Database is stored in temporary directory %s', $DataDir));
  2312. }
  2313. $html .= T($FooterNote) if $FooterNote;
  2314. $html .= $q->p(Ts('%s seconds', (time - $Now))) if GetParam('timing', 0);
  2315. return "<footer>$html</footer>";
  2316. }
  2317. sub GetFooterTimestamp {
  2318. my ($id, $rev, $page) = @_;
  2319. $page //= \%Page;
  2320. if ($id and $rev ne 'history' and $rev ne 'edit' and $page->{revision}) {
  2321. my @elements = (($rev eq '' ? T('Last edited') : T('Edited')), TimeToText($page->{ts}),
  2322. Ts('by %s', GetAuthorLink($page->{username})));
  2323. push(@elements, ScriptLinkDiff(2, $id, T('(diff)'), $rev)) if $UseDiff and $page->{revision} > 1;
  2324. return $q->div({-class=>'time'}, @elements);
  2325. }
  2326. return '';
  2327. }
  2328. sub GetFooterLinks {
  2329. my ($id, $rev) = @_;
  2330. my @elements;
  2331. if ($id and $rev ne 'history' and $rev ne 'edit') {
  2332. if ($CommentsPattern) {
  2333. if ($id =~ /$CommentsPattern/) {
  2334. push(@elements, GetPageLink($1, undef, 'original', T('a'))) if $1;
  2335. } else {
  2336. push(@elements, GetPageLink($CommentsPrefix . $id, undef, 'comment', T('c')));
  2337. }
  2338. }
  2339. if (UserCanEdit($id, 0)) {
  2340. if ($rev) { # showing old revision
  2341. push(@elements, GetOldPageLink('edit', $id, $rev, Ts('Edit revision %s of this page', $rev)));
  2342. } else { # showing current revision
  2343. push(@elements, GetEditLink($id, T('Edit this page'), undef, T('e')));
  2344. }
  2345. } else { # no permission or generated page
  2346. push(@elements, ScriptLink('action=password', T('This page is read-only'), 'password'));
  2347. }
  2348. }
  2349. push(@elements, GetHistoryLink($id, T('View other revisions'))) if $Action{history} and $id and $rev ne 'history';
  2350. push(@elements, GetPageLink($id, T('View current revision')),
  2351. GetRCLink($id, T('View all changes'))) if $Action{history} and $rev ne '';
  2352. if ($Action{contrib} and $id and $rev eq 'history') {
  2353. push(@elements, ScriptLink("action=contrib;id=" . UrlEncode($id), T('View contributors'), 'contrib'));
  2354. }
  2355. if ($Action{admin} and GetParam('action', '') ne 'admin') {
  2356. my $action = 'action=admin';
  2357. $action .= ';id=' . UrlEncode($id) if $id;
  2358. push(@elements, ScriptLink($action, T('Administration'), 'admin'));
  2359. }
  2360. return @elements ? $q->div({-class=>'edit bar'}, @elements) : '';
  2361. }
  2362. sub GetCommentForm {
  2363. my ($id, $rev, $comment) = @_;
  2364. if ($CommentsPattern ne '' and $id and $rev ne 'history' and $rev ne 'edit'
  2365. and $id =~ /$CommentsPattern/ and UserCanEdit($id, 0, 1)) {
  2366. my $html = $q->div({-class=>'comment'},
  2367. GetFormStart(undef, undef, 'comment'),
  2368. $q->p(GetHiddenValue('title', $id),
  2369. $q->label({-for=>'aftertext', -accesskey=>T('c')},
  2370. T('Add your comment here:')), $q->br(),
  2371. GetTextArea('aftertext', $comment, 10)),
  2372. $EditNote,
  2373. $q->p($q->span({-class=>'username'},
  2374. $q->label({-for=>'username'}, T('Username:')), ' ',
  2375. $q->textfield(-name=>'username', -id=>'username',
  2376. -default=>GetParam('username', ''),
  2377. -override=>1, -size=>20, -maxlength=>50)),
  2378. $q->span({-class=>'homepage'},
  2379. $q->label({-for=>'homepage'}, T('Homepage URL:')), ' ',
  2380. $q->textfield(-name=>'homepage', -id=>'homepage',
  2381. -default=>GetParam('homepage', ''),
  2382. -override=>1, -size=>40, -maxlength=>100))),
  2383. $q->p($q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save')), ' ',
  2384. $q->submit(-name=>'Preview', -accesskey=>T('p'), -value=>T('Preview'))),
  2385. $q->end_form());
  2386. foreach my $sub (@MyFormChanges) {
  2387. $html = $sub->($html, 'comment');
  2388. }
  2389. return $html;
  2390. }
  2391. return '';
  2392. }
  2393. sub GetFormStart {
  2394. my ($ignore, $method, $class) = @_;
  2395. $method ||= 'post';
  2396. $class ||= 'form';
  2397. return $q->start_multipart_form(-method=>$method, -action=>$FullUrl,
  2398. -accept_charset=>'utf-8', -class=>$class);
  2399. }
  2400. sub GetSearchForm {
  2401. my $html = GetFormStart(undef, 'get', 'search') . $q->start_p;
  2402. $html .= $q->label({-for=>'search'}, T('Search:')) . ' '
  2403. . $q->textfield(-name=>'search', -id=>'search', -size=>15, -accesskey=>T('f')) . ' ';
  2404. if (GetParam('search') ne '' and UserIsAdmin()) { # see DoBrowseRequest
  2405. $html .= $q->label({-for=>'replace'}, T('Replace:')) . ' '
  2406. . $q->textfield(-name=>'replace', -id=>'replace', -size=>20) . ' '
  2407. . $q->label({-for=>'delete', -title=>'If you want to replace matches with the empty string'}, T('Delete')) . ' '
  2408. . $q->input({-type=>'checkbox', -name=>'delete'})
  2409. . $q->submit('preview', T('Preview'));
  2410. }
  2411. if (GetParam('matchingpages', $MatchingPages)) {
  2412. $html .= $q->label({-for=>'matchingpage'}, T('Filter:')) . ' '
  2413. . $q->textfield(-name=>'match', -id=>'matchingpage', -size=>15) . ' ';
  2414. }
  2415. if (%Languages) {
  2416. $html .= $q->label({-for=>'searchlang'}, T('Language:')) . ' '
  2417. . $q->textfield(-name=>'lang', -id=>'searchlang', -size=>5, -default=>GetParam('lang', '')) . ' ';
  2418. }
  2419. $html .= $q->submit('dosearch', T('Go!')) . $q->end_p . $q->end_form;
  2420. return $html;
  2421. }
  2422. sub GetGotoBar { # ignore $id parameter
  2423. return $q->span({-class=>'gotobar bar'}, (map { GetPageLink($_) } @UserGotoBarPages), $UserGotoBar);
  2424. }
  2425. # return list of summaries between two revisions, assuming the open page is the upper one
  2426. sub DiffSummary {
  2427. my ($current, $from, $to) = @_;
  2428. my @summaries = ($current); # the current summary is not in a kept file
  2429. unshift(@summaries, map { GetKeptRevision($_)->{summary} } ($from + 1 .. $to - 1)) if $from and $to;
  2430. my ($last, @result);
  2431. for my $summary (@summaries) {
  2432. $summary =~ s/^\s+//; # squish leading whitespace
  2433. next unless $summary; # not empty
  2434. next if $summary eq $last; # not a repeat
  2435. push(@result, QuoteHtml($summary));
  2436. $last = $summary;
  2437. }
  2438. return '' unless @result;
  2439. return $q->p({-class=>'summary'}, T('Summary:'), $result[0]) if @result == 1;
  2440. return $q->div({-class=>'summary'}, $q->p(T('Summary:')), $q->ul($q->li(\@result)));
  2441. }
  2442. sub PrintHtmlDiff {
  2443. my ($type, $old, $page, $current) = @_;
  2444. $page //= \%Page;
  2445. $current //= $page->{revision};
  2446. $type = 2 if $old or $page->{revision} != $current; # explicit revisions means minor diffs!
  2447. $old //= $page->{$type == 1 ? 'lastmajor' : 'revision'} - 1; # default diff revision if none given
  2448. my ($diff, $summary);
  2449. my $intro = T('Last edit');
  2450. # use the cached diff and summary if possible
  2451. if ($old == $page->{$type == 1 ? 'lastmajor' : 'revision'} - 1) {
  2452. $diff = GetCacheDiff($type == 1 ? 'major' : 'minor', $page);
  2453. # just add the last diff in the right format
  2454. $summary = DiffSummary($page->{$type == 1 ? 'lastmajorsummary' : 'summary'});
  2455. }
  2456. # if there was no cached diff: compute it, and new intro
  2457. if (not $diff and $old > 0) {
  2458. ($diff, my $keptPage) = GetKeptDiff($page->{text}, $old);
  2459. my $to = $page->{revision} != $current ? Ts('revision %s', $page->{revision}) : T('current revision');
  2460. $intro = Tss('Difference between revision %1 and %2', $old, $to);
  2461. $summary = DiffSummary($page->{summary}, $old, $page->{revision});
  2462. }
  2463. # if this is the last major diff and there are minor diffs to look at, and we
  2464. # didn't request a particular old revision
  2465. if ($type == 1 and $page->{lastmajor} and $page->{lastmajor} != $current) {
  2466. $intro = Ts('Last major edit (%s)', ScriptLinkDiff(2, $OpenPageName, T('later minor edits'),
  2467. undef, $page->{lastmajor} || 1));
  2468. }
  2469. $diff =~ s!<p><strong>(.*?)</strong></p>!'<p><strong>' . T($1) . '</strong></p>'!eg;
  2470. $diff ||= T('No diff available.');
  2471. print $q->div({-class=>'diff'}, $q->p($q->b($intro)), $summary, $diff);
  2472. }
  2473. sub GetCacheDiff {
  2474. my ($type, $page) = @_;
  2475. my $diff = $page->{"diff-$type"};
  2476. $diff = $page->{"diff-minor"} if $diff eq '1'; # if major eq minor diff
  2477. return $diff;
  2478. }
  2479. sub GetKeptDiff {
  2480. my ($new, $revision) = @_;
  2481. $revision ||= 1;
  2482. my ($revisionPage, $rev) = GetTextRevision($revision, 1);
  2483. return '', $revisionPage unless $rev;
  2484. return T("The two revisions are the same."), $revisionPage if $revisionPage->{text} eq $new;
  2485. return GetDiff($revisionPage->{text}, $new, $rev), $revisionPage;
  2486. }
  2487. sub DoDiff { # Actualy call the diff program
  2488. CreateDir($TempDir);
  2489. my $oldName = "$TempDir/old";
  2490. my $newName = "$TempDir/new";
  2491. RequestLockDir('diff') or return '';
  2492. WriteStringToFile($oldName, $_[0]);
  2493. WriteStringToFile($newName, $_[1]);
  2494. my $command = encode_utf8("diff -- \Q$oldName\E \Q$newName\E");
  2495. my $diff_out = decode_utf8(qx($command));
  2496. ReleaseLockDir('diff');
  2497. $diff_out =~ s/\n\K\\ No newline.*\n//g; # Get rid of common complaint.
  2498. # No need to unlink temp files--next diff will just overwrite.
  2499. return $diff_out;
  2500. }
  2501. sub GetDiff {
  2502. my ($old, $new, $revision) = @_;
  2503. my $old_is_file = (TextIsFile($old))[0] || '';
  2504. my $old_is_image = ($old_is_file =~ /^image\//);
  2505. my $new_is_file = TextIsFile($new);
  2506. if ($old_is_file or $new_is_file) {
  2507. return $q->p($q->strong(T('Old revision:')))
  2508. . $q->div({-class=>'old'}, # don't pring new revision, because that's the one that gets shown!
  2509. $q->p($old_is_file ? GetDownloadLink($OpenPageName, $old_is_image, $revision) : $old))
  2510. }
  2511. $old =~ s/[\r\n]+/\n/g;
  2512. $new =~ s/[\r\n]+/\n/g;
  2513. return ImproveDiff(DoDiff($old, $new));
  2514. }
  2515. sub ImproveDiff { # NO NEED TO BE called within a diff lock
  2516. my $diff = QuoteHtml(shift);
  2517. $diff =~ tr/\r//d;
  2518. my @hunks = split (/^(\d+,?\d*[adc]\d+,?\d*\n)/m, $diff);
  2519. my $result = shift (@hunks); # intro
  2520. while ($#hunks > 0) { # at least one header and a real hunk
  2521. my $header = shift (@hunks);
  2522. $header =~ s|^(\d+.*c.*)|<p><strong>Changed:</strong></p>| # T('Changed:')
  2523. or $header =~ s|^(\d+.*d.*)|<p><strong>Deleted:</strong></p>| # T('Deleted:')
  2524. or $header =~ s|^(\d+.*a.*)|<p><strong>Added:</strong></p>|; # T('Added:')
  2525. $result .= $header;
  2526. my $chunk = shift (@hunks);
  2527. my ($old, $new) = split (/\n---\n/, $chunk, 2);
  2528. if ($old and $new) {
  2529. ($old, $new) = DiffMarkWords($old, $new);
  2530. $result .= "$old<p><strong>to</strong></p>\n$new"; # T('to')
  2531. } else {
  2532. if (substr($chunk, 0, 2) eq '&g') {
  2533. $result .= DiffAddPrefix(DiffStripPrefix($chunk), '&gt; ', 'new');
  2534. } else {
  2535. $result .= DiffAddPrefix(DiffStripPrefix($chunk), '&lt; ', 'old');
  2536. }
  2537. }
  2538. }
  2539. return $result;
  2540. }
  2541. sub DiffMarkWords {
  2542. my ($old, $new) = map { DiffStripPrefix($_) } @_;
  2543. my @diffs = grep(/^\d/, split(/\n/, DoDiff(join("\n", split(/\s+|\b/, $old)) . "\n",
  2544. join("\n", split(/\s+|\b/, $new)) . "\n")));
  2545. foreach my $diff (reverse @diffs) { # so that new html tags don't confuse word counts
  2546. my ($start1, $end1, $type, $start2, $end2) = $diff =~ /^(\d+),?(\d*)([adc])(\d+),?(\d*)$/gm;
  2547. if ($type eq 'd' or $type eq 'c') {
  2548. $end1 ||= $start1;
  2549. $old = DiffHtmlMarkWords($old, $start1, $end1);
  2550. }
  2551. if ($type eq 'a' or $type eq 'c') {
  2552. $end2 ||= $start2;
  2553. $new = DiffHtmlMarkWords($new, $start2, $end2);
  2554. }
  2555. }
  2556. return (DiffAddPrefix($old, '&lt; ', 'old'),
  2557. DiffAddPrefix($new, '&gt; ', 'new'));
  2558. }
  2559. sub DiffHtmlMarkWords {
  2560. my ($text, $start, $end) = @_;
  2561. my @fragments = split(/(\s+|\b)/, $text);
  2562. splice(@fragments, 2 * ($start - 1), 0, '<strong class="changes">');
  2563. splice(@fragments, 2 * $end, 0, '</strong>');
  2564. my $result = join('', @fragments);
  2565. $result =~ s!&<(/?)strong([^>]*)>(amp|[gl]t);!<$1strong$2>&$3;!g;
  2566. $result =~ s!&(amp|[gl]t)<(/?)strong([^>]*)>;!&$1;<$2strong$3>!g;
  2567. return $result;
  2568. }
  2569. sub DiffStripPrefix {
  2570. my $str = shift;
  2571. $str =~ s/^&[lg]t; //gm;
  2572. return $str;
  2573. }
  2574. sub DiffAddPrefix {
  2575. my ($str, $prefix, $class) = @_;
  2576. my @lines = split(/\n/, $str);
  2577. for my $line (@lines) {
  2578. $line = $prefix . $line;
  2579. }
  2580. return $q->div({-class=>$class}, $q->p(join($q->br(), @lines)));
  2581. }
  2582. sub ParseData {
  2583. my $data = shift;
  2584. my %result;
  2585. while ($data =~ /(\S+?): (.*?)(?=\n[^ \t]|\Z)/gs) {
  2586. my ($key, $value) = ($1, $2);
  2587. $value =~ s/\n\t/\n/g;
  2588. $result{$key} = $value;
  2589. }
  2590. # return unless %result; # undef instead of empty hash # TODO should we do that?
  2591. return wantarray ? %result : \%result; # return list sometimes for compatibility
  2592. }
  2593. sub OpenPage { # Sets global variables
  2594. my $id = shift;
  2595. return if $OpenPageName eq $id;
  2596. if ($IndexHash{$id}) {
  2597. %Page = %{ParseData(ReadFileOrDie(GetPageFile($id)))};
  2598. } else {
  2599. %Page = ();
  2600. $Page{ts} = $Now;
  2601. $Page{revision} = 0;
  2602. }
  2603. $OpenPageName = $id;
  2604. }
  2605. sub GetTextAtTime { # call with opened page, return $minor if all pages between now and $ts are minor!
  2606. my $ts = shift;
  2607. my $minor = $Page{minor};
  2608. return ($Page{text}, $minor, 0) if $Page{ts} <= $ts; # current page is old enough
  2609. return ($DeletedPage, $minor, 0) if $Page{revision} == 1 and $Page{ts} > $ts; # created after $ts
  2610. my $keep = {}; # info may be needed after the loop
  2611. foreach my $revision (GetKeepRevisions($OpenPageName)) {
  2612. $keep = GetKeptRevision($revision);
  2613. # $minor = 0 unless defined $keep; # TODO?
  2614. $minor = 0 if not $keep->{minor} and $keep->{ts} >= $ts; # ignore keep{minor} if keep{ts} is too old
  2615. return ($keep->{text}, $minor, 0) if $keep->{ts} <= $ts;
  2616. }
  2617. return ($DeletedPage, $minor, 0) if $keep->{revision} == 1; # then the page was created after $ts!
  2618. return ($keep->{text}, $minor, $keep->{ts}); # the oldest revision available is not old enough
  2619. }
  2620. sub GetTextRevision {
  2621. my ($revision, $quiet) = @_;
  2622. $revision =~ s/\D//g; # Remove non-numeric chars
  2623. return wantarray ? (\%Page, $revision) : \%Page unless $revision and $revision ne $Page{revision};
  2624. my $keep = GetKeptRevision($revision);
  2625. if (not defined $keep) {
  2626. $Message .= $q->p(Ts('Revision %s not available', $revision)
  2627. . ' (' . T('showing current revision instead') . ')') unless $quiet;
  2628. return wantarray ? (\%Page, '') : \%Page;
  2629. }
  2630. $Message .= $q->p(Ts('Showing revision %s', $revision)) unless $quiet;
  2631. return wantarray ? ($keep, $revision) : $keep;
  2632. }
  2633. sub GetPageContent {
  2634. my $id = shift;
  2635. return ParseData(ReadFileOrDie(GetPageFile($id)))->{text} if $IndexHash{$id};
  2636. return '';
  2637. }
  2638. sub GetKeptRevision { # Call after OpenPage
  2639. my ($status, $data) = ReadFile(GetKeepFile($OpenPageName, (shift)));
  2640. return unless $status;
  2641. return ParseData($data);
  2642. }
  2643. sub GetPageFile {
  2644. my ($id) = @_;
  2645. return "$PageDir/$id.pg";
  2646. }
  2647. sub GetKeepFile {
  2648. my ($id, $revision) = @_; die "No revision for $id" unless $revision; #FIXME
  2649. return GetKeepDir($id) . "/$revision.kp";
  2650. }
  2651. sub GetKeepDir {
  2652. my $id = shift; die 'No id' unless $id; #FIXME
  2653. return "$KeepDir/$id";
  2654. }
  2655. sub GetKeepFiles {
  2656. return Glob(GetKeepDir(shift) . '/*.kp'); # files such as 1.kp, 2.kp, etc.
  2657. }
  2658. sub GetKeepRevisions {
  2659. my @result = sort {$b <=> $a} map { m/([0-9]+)\.kp$/; $1; } GetKeepFiles(shift);
  2660. return @result;
  2661. }
  2662. # Always call SavePage within a lock.
  2663. sub SavePage { # updating the cache will not change timestamp and revision!
  2664. ReportError(T('Cannot save a nameless page.'), '400 BAD REQUEST', 1) unless $OpenPageName;
  2665. ReportError(T('Cannot save a page without revision.'), '400 BAD REQUEST', 1) unless $Page{revision};
  2666. CreateDir($PageDir);
  2667. WriteStringToFile(GetPageFile($OpenPageName), EncodePage(%Page));
  2668. }
  2669. sub SaveKeepFile {
  2670. return if ($Page{revision} < 1); # Don't keep 'empty' revision
  2671. delete $Page{blocks}; # delete some info from the page
  2672. delete $Page{flags};
  2673. delete $Page{'diff-major'};
  2674. delete $Page{'diff-minor'};
  2675. $Page{'keep-ts'} = $Now; # expire only $KeepDays from $Now!
  2676. CreateDir($KeepDir);
  2677. CreateDir(GetKeepDir($OpenPageName));
  2678. WriteStringToFile(GetKeepFile($OpenPageName, $Page{revision}), EncodePage(%Page));
  2679. }
  2680. sub EncodePage {
  2681. my @data = @_;
  2682. my $result = '';
  2683. $result .= (shift @data) . ': ' . EscapeNewlines(shift @data) . "\n" while (@data);
  2684. return $result;
  2685. }
  2686. sub EscapeNewlines {
  2687. $_[0] =~ s/\n/\n\t/g; # modify original instead of copying
  2688. return $_[0];
  2689. }
  2690. sub ExpireAllKeepFiles {
  2691. foreach my $name (AllPagesList()) {
  2692. print $q->br(), GetPageLink($name);
  2693. OpenPage($name);
  2694. my $delete = PageDeletable();
  2695. if ($delete) {
  2696. my $status = DeletePage($OpenPageName);
  2697. print ' ', ($status ? T('not deleted:') . ' ' . $status : T('deleted'));
  2698. } else {
  2699. ExpireKeepFiles();
  2700. }
  2701. }
  2702. }
  2703. sub ExpireKeepFiles { # call with opened page
  2704. return unless $KeepDays;
  2705. my $expirets = $Now - ($KeepDays * 86400); # 24*60*60
  2706. foreach my $revision (GetKeepRevisions($OpenPageName)) {
  2707. my $keep = GetKeptRevision($revision);
  2708. next if $keep->{'keep-ts'} >= $expirets;
  2709. next if $KeepMajor and $keep->{revision} == $Page{lastmajor};
  2710. Unlink(GetKeepFile($OpenPageName, $revision));
  2711. }
  2712. }
  2713. sub ReadFile {
  2714. if (open(my $IN, '<:encoding(UTF-8)', encode_utf8(shift))) {
  2715. local $/ = undef; # Read complete files
  2716. my $data=<$IN>;
  2717. close $IN;
  2718. return (1, $data);
  2719. }
  2720. return (0, '');
  2721. }
  2722. sub ReadFileOrDie {
  2723. my ($file) = @_;
  2724. my ($status, $data);
  2725. ($status, $data) = ReadFile($file);
  2726. if (not $status) {
  2727. ReportError(Ts('Cannot open %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
  2728. }
  2729. return $data;
  2730. }
  2731. sub WriteStringToFile {
  2732. my ($file, $string) = @_;
  2733. open(my $OUT, '>:encoding(UTF-8)', encode_utf8($file))
  2734. or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
  2735. print $OUT $string;
  2736. close($OUT);
  2737. }
  2738. sub AppendStringToFile {
  2739. my ($file, $string) = @_;
  2740. open(my $OUT, '>>:encoding(UTF-8)', encode_utf8($file))
  2741. or ReportError(Ts('Cannot write %s', $file) . ": $!", '500 INTERNAL SERVER ERROR');
  2742. print $OUT $string;
  2743. close($OUT);
  2744. }
  2745. sub IsFile { return -f encode_utf8(shift); }
  2746. sub IsDir { return -d encode_utf8(shift); }
  2747. sub ZeroSize { return -z encode_utf8(shift); }
  2748. sub Unlink { return unlink(map { encode_utf8($_) } @_); }
  2749. sub Modified { return (stat(encode_utf8(shift)))[9]; }
  2750. sub Glob { return map { decode_utf8($_) } bsd_glob(encode_utf8(shift)); }
  2751. sub ChangeMod { return chmod(shift, map { encode_utf8($_) } @_); }
  2752. sub Rename { return rename(encode_utf8($_[0]), encode_utf8($_[1])); }
  2753. sub RemoveDir { return rmdir(encode_utf8(shift)); }
  2754. sub ChangeDir { return chdir(encode_utf8(shift)); }
  2755. sub CreateDir {
  2756. my ($newdir) = @_;
  2757. return if IsDir($newdir);
  2758. mkdir(encode_utf8($newdir), 0775)
  2759. or ReportError(Ts('Cannot create %s', $newdir) . ": $!", '500 INTERNAL SERVER ERROR');
  2760. }
  2761. sub GetLockedPageFile {
  2762. my $id = shift;
  2763. return "$PageDir/$id.lck";
  2764. }
  2765. sub RequestLockDir {
  2766. my ($name, $tries, $wait, $error, $retried) = @_;
  2767. $tries ||= 4;
  2768. $wait ||= 2;
  2769. CreateDir($TempDir);
  2770. my $lock = $LockDir . $name;
  2771. my $n = 0;
  2772. # Cannot use CreateDir because we don't want to skip mkdir if the directory
  2773. # already exists.
  2774. while (mkdir(encode_utf8($lock), 0555) == 0) {
  2775. if ($n++ >= $tries) {
  2776. my $ts = Modified($lock);
  2777. if ($Now - $ts > $LockExpiration and $LockExpires{$name} and not $retried) { # XXX should we remove this now?
  2778. ReleaseLockDir($name); # try to expire lock (no checking)
  2779. return 1 if RequestLockDir($name, undef, undef, undef, 1);
  2780. }
  2781. return 0 unless $error;
  2782. ReportError(Ts('Could not get %s lock', $name) . ": $!. ",
  2783. '503 SERVICE UNAVAILABLE', undef,
  2784. Ts('The lock was created %s.', CalcTimeSince($Now - $ts))
  2785. . ($retried && ' ' . T('Maybe the user running this script is no longer allowed to remove the lock directory?'))
  2786. . ' ' . T('Sometimes locks are left behind if a job crashes.') . ' '
  2787. . ($Now - $ts < 600 ? T('After ten minutes, you could try to unlock the wiki.')
  2788. : ScriptLink('action=unlock', T('Unlock Wiki'), 'unlock')));
  2789. }
  2790. sleep($wait);
  2791. }
  2792. $Locks{$name} = 1;
  2793. return 1;
  2794. }
  2795. sub HandleSignals {
  2796. my ($signal) = @_; # TODO should we pass it to CleanLock?
  2797. CleanLock($_) foreach keys %Locks;
  2798. exit; # let's count it as graceful exit
  2799. }
  2800. sub CleanLock {
  2801. my ($name) = @_;
  2802. $LockCleaners{$name}->() if exists $LockCleaners{$name};
  2803. ReleaseLockDir($name); # TODO should we log this?
  2804. }
  2805. sub ReleaseLockDir {
  2806. my $name = shift; # We don't check whether we succeeded.
  2807. RemoveDir($LockDir . $name); # Before fixing, make sure we only call this
  2808. delete $Locks{$name}; # when we know the lock exists.
  2809. }
  2810. sub RequestLockOrError {
  2811. return RequestLockDir('main', 10, 3, 1); # 10 tries, 3 second wait, die on error
  2812. }
  2813. sub ReleaseLock {
  2814. ReleaseLockDir('main');
  2815. }
  2816. sub ForceReleaseLock {
  2817. my $pattern = shift;
  2818. my $forced;
  2819. foreach my $name (Glob($pattern)) {
  2820. # First try to obtain lock (in case of normal edit lock)
  2821. $forced = 1 unless RequestLockDir($name, 5, 3, 0);
  2822. ReleaseLockDir($name); # Release the lock, even if we didn't get it. This should not happen.
  2823. }
  2824. return $forced;
  2825. }
  2826. sub DoUnlock {
  2827. my $message = '';
  2828. print GetHeader('', T('Unlock Wiki'), undef, 'nocache');
  2829. print $q->p(T('This operation may take several seconds...'));
  2830. for my $lock (@KnownLocks) {
  2831. if (ForceReleaseLock($lock)) {
  2832. $message .= $q->p(Ts('Forced unlock of %s lock.', $lock));
  2833. }
  2834. }
  2835. print $message || $q->p(T('No unlock required.'));
  2836. PrintFooter();
  2837. }
  2838. sub CalcDay {
  2839. my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
  2840. return sprintf('%4d-%02d-%02d', $year + 1900, $mon + 1, $mday);
  2841. }
  2842. sub CalcTime {
  2843. my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift);
  2844. return sprintf('%02d:%02d UTC', $hour, $min);
  2845. }
  2846. sub CalcTimeSince {
  2847. my $total = shift;
  2848. return Ts('%s hours ago', int($total/3600)) if ($total >= 7200);
  2849. return T('1 hour ago') if ($total >= 3600);
  2850. return Ts('%s minutes ago', int($total/60)) if ($total >= 120);
  2851. return T('1 minute ago') if ($total >= 60);
  2852. return Ts('%s seconds ago', int($total)) if ($total >= 2);
  2853. return T('1 second ago') if ($total == 1);
  2854. return T('just now');
  2855. }
  2856. sub TimeToText {
  2857. my $t = shift;
  2858. return CalcDay($t) . ' ' . CalcTime($t);
  2859. }
  2860. sub TimeToW3 { # Complete date plus hours and minutes: YYYY-MM-DDThh:mmTZD (eg 1997-07-16T19:20+01:00)
  2861. my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift); # use special UTC designator ("Z")
  2862. return sprintf('%4d-%02d-%02dT%02d:%02dZ', $year + 1900, $mon + 1, $mday, $hour, $min);
  2863. }
  2864. sub TimeToRFC822 {
  2865. my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime(shift); # Sat, 07 Sep 2002 00:00:01 GMT
  2866. return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", qw(Sun Mon Tue Wed Thu Fri Sat)[$wday], $mday,
  2867. qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon], $year + 1900, $hour, $min, $sec);
  2868. }
  2869. sub GetHiddenValue {
  2870. my ($name, $value) = @_;
  2871. return $q->input({-type=>"hidden", -name=>$name, -value=>$value});
  2872. }
  2873. sub FreeToNormal { # trim all spaces and convert them to underlines
  2874. my $id = shift;
  2875. return '' unless $id;
  2876. $id =~ s/ /_/g;
  2877. $id =~ s/__+/_/g;
  2878. $id =~ s/^_//;
  2879. $id =~ s/_$//;
  2880. return UnquoteHtml($id);
  2881. }
  2882. sub ItemName {
  2883. my $id = shift; # id
  2884. return NormalToFree($id) unless GetParam('short', 1) and $RssStrip;
  2885. my $comment = $id =~ s/^($CommentsPrefix)//; # strip first so that ^ works
  2886. $id =~ s/^$RssStrip//;
  2887. $id = $CommentsPrefix . $id if $comment;
  2888. return NormalToFree($id);
  2889. }
  2890. sub NormalToFree { # returns HTML quoted title with spaces
  2891. my $title = shift;
  2892. $title =~ s/_/ /g;
  2893. return QuoteHtml($title);
  2894. }
  2895. sub UnWiki {
  2896. my $str = shift;
  2897. return $str unless $WikiLinks and $str =~ /^$LinkPattern$/;
  2898. $str =~ s/([[:lower:]])([[:upper:]])/$1 $2/g;
  2899. return $str;
  2900. }
  2901. sub DoEdit {
  2902. my ($id, $newText, $preview) = @_;
  2903. UserCanEditOrDie($id);
  2904. my $upload = GetParam('upload', undef);
  2905. if ($upload and not $UploadAllowed and not UserIsAdmin()) {
  2906. ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
  2907. }
  2908. OpenPage($id);
  2909. my ($revisionPage, $revision) = GetTextRevision(GetParam('revision', ''), 1); # maybe revision reset!
  2910. my $oldText = $preview ? $newText : $revisionPage->{text};
  2911. my $isFile = TextIsFile($oldText);
  2912. $upload //= $isFile;
  2913. if ($upload and not $UploadAllowed and not UserIsAdmin()) {
  2914. ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
  2915. }
  2916. if ($upload) { # shortcut lots of code
  2917. $revision = '';
  2918. $preview = 0;
  2919. } elsif ($isFile) {
  2920. $oldText = '';
  2921. }
  2922. my $header;
  2923. if ($revision and not $upload) {
  2924. $header = Ts('Editing revision %s of', $revision) . ' ' . NormalToFree($id);
  2925. } else {
  2926. $header = Ts('Editing %s', NormalToFree($id));
  2927. }
  2928. print GetHeader('', $header), $q->start_div({-class=>'content edit'});
  2929. if ($preview and not $upload) {
  2930. print $q->start_div({-class=>'preview'});
  2931. print $q->h2(T('Preview:'));
  2932. PrintWikiToHTML($oldText); # no caching, current revision, unlocked
  2933. print $q->hr(), $q->h2(T('Preview only, not yet saved')), $q->end_div();
  2934. }
  2935. if ($revision) {
  2936. print $q->strong(Ts('Editing old revision %s.', $revision) . ' '
  2937. . T('Saving this page will replace the latest revision with this text.'))
  2938. }
  2939. print GetEditForm($id, $upload, $oldText, $revision), $q->end_div();
  2940. PrintFooter($id, 'edit');
  2941. }
  2942. sub GetEditForm {
  2943. my ($page_name, $upload, $oldText, $revision) = @_;
  2944. my $html = GetFormStart(undef, undef, $upload ? 'edit upload' : 'edit text') # protected by questionasker
  2945. .$q->p(GetHiddenValue("title", $page_name),
  2946. ($revision ? GetHiddenValue('revision', $revision) : ''),
  2947. GetHiddenValue('oldtime', GetParam('oldtime', $Page{ts})), # prefer parameter over actual timestamp
  2948. ($upload ? GetUpload() : GetTextArea('text', $oldText)));
  2949. my $summary = UnquoteHtml(GetParam('summary', ''))
  2950. || ($Now - $Page{ts} < ($SummaryHours * 3600) ? $Page{summary} : '');
  2951. $html .= $q->p(T('Summary:').$q->br().GetTextArea('summary', $summary, 2))
  2952. .$q->p($q->checkbox(-name=>'recent_edit', -checked=>(GetParam('recent_edit', '') eq 'on'),
  2953. -label=>T('This change is a minor edit.')));
  2954. $html .= T($EditNote) if $EditNote; # Allow translation
  2955. my $username = GetParam('username', '');
  2956. $html .= $q->p($q->label({-for=>'username'}, T('Username:')).' '
  2957. .$q->textfield(-name=>'username', -id=>'username', -default=>$username,
  2958. -override=>1, -size=>20, -maxlength=>50))
  2959. .$q->p($q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save')),
  2960. ($upload ? '' : ' ' . $q->submit(-name=>'Preview', -accesskey=>T('p'), -value=>T('Preview'))).
  2961. ' '.$q->submit(-name=>'Cancel', -value=>T('Cancel')));
  2962. if ($upload) {
  2963. $html .= $q->p(ScriptLink('action=edit;upload=0;id=' . UrlEncode($page_name), T('Replace this file with text'), 'upload'));
  2964. } elsif ($UploadAllowed or UserIsAdmin()) {
  2965. $html .= $q->p(ScriptLink('action=edit;upload=1;id=' . UrlEncode($page_name), T('Replace this text with a file'), 'upload'));
  2966. }
  2967. $html .= $q->end_form();
  2968. foreach my $sub (@MyFormChanges) {
  2969. $html = $sub->($html, 'edit', $upload);
  2970. }
  2971. return $html;
  2972. }
  2973. sub GetTextArea {
  2974. my ($name, $text, $rows) = @_;
  2975. return $q->textarea(-id=>$name, -name=>$name, -default=>$text, -rows=>$rows || 25, -columns=>78, -override=>1);
  2976. }
  2977. sub GetUpload {
  2978. return T('File to upload:') . ' ' . $q->filefield(-name=>'file', -size=>50, -maxlength=>100);
  2979. }
  2980. sub DoDownload {
  2981. my $id = shift;
  2982. OpenPage($id) if ValidIdOrDie($id);
  2983. print $q->header(-status=>'304 NOT MODIFIED') and return if FileFresh(); # FileFresh needs an OpenPage!
  2984. my ($revisionPage, $revision) = GetTextRevision(GetParam('revision', '')); # maybe revision reset!
  2985. my $text = $revisionPage->{text};
  2986. if (my ($type, $encoding) = TextIsFile($text)) {
  2987. my ($data) = $text =~ /^[^\n]*\n(.*)/s;
  2988. my %allowed = map {$_ => 1} @UploadTypes;
  2989. if (@UploadTypes and not $allowed{$type}) {
  2990. ReportError(Ts('Files of type %s are not allowed.', $type), '415 UNSUPPORTED MEDIA TYPE');
  2991. }
  2992. print GetHttpHeader($type, $Page{ts}, undef, $encoding);
  2993. require MIME::Base64;
  2994. binmode(STDOUT, ":pop:raw"); # need to pop utf8 for Windows users!?
  2995. print MIME::Base64::decode($data);
  2996. } else {
  2997. print GetHttpHeader('text/plain', $Page{ts});
  2998. print $text;
  2999. }
  3000. }
  3001. sub DoPassword {
  3002. my $id = shift;
  3003. print GetHeader('', T('Password')), $q->start_div({-class=>'content password'});
  3004. print $q->p(T('Your password is saved in a cookie, if you have cookies enabled. Cookies may get lost if you connect from another machine, from another account, or using another software.'));
  3005. if (not $AdminPass and not $EditPass) {
  3006. print $q->p(T('This site does not use admin or editor passwords.'));
  3007. } else {
  3008. if (UserIsAdmin()) {
  3009. print $q->p(T('You are currently an administrator on this site.'));
  3010. } elsif (UserIsEditor()) {
  3011. print $q->p(T('You are currently an editor on this site.'));
  3012. } else {
  3013. print $q->p(T('You are a normal user on this site.'));
  3014. if (not GetParam('pwd')) {
  3015. print $q->p(T('You do not have a password set.'));
  3016. } else {
  3017. print $q->p(T('Your password does not match any of the administrator or editor passwords.'));
  3018. }
  3019. }
  3020. print GetFormStart(undef, undef, 'password'),
  3021. $q->p(GetHiddenValue('action', 'password'), T('Password:'), ' ',
  3022. $q->password_field(-name=>'pwd', -size=>20, -maxlength=>64),
  3023. $q->hidden(-name=>'id', -value=>$id),
  3024. $q->submit(-name=>'Save', -accesskey=>T('s'), -value=>T('Save'))),
  3025. $q->end_form;
  3026. }
  3027. if ($id) {
  3028. print $q->p(ScriptLink('action=browse;id=' . UrlEncode($id) . ';time=' . time,
  3029. Ts('Return to %s', NormalToFree($id))));
  3030. }
  3031. print $q->end_div();
  3032. PrintFooter();
  3033. }
  3034. sub UserIsEditorOrError {
  3035. UserIsEditor()
  3036. or ReportError(T('This operation is restricted to site editors only...'), '403 FORBIDDEN');
  3037. return 1;
  3038. }
  3039. sub UserIsAdminOrError {
  3040. UserIsAdmin()
  3041. or ReportError(T('This operation is restricted to administrators only...'), '403 FORBIDDEN');
  3042. return 1;
  3043. }
  3044. sub UserCanEditOrDie {
  3045. my $id = shift;
  3046. ValidIdOrDie($id);
  3047. if (not UserCanEdit($id, 1)) {
  3048. my $rule = UserIsBanned();
  3049. if ($rule) {
  3050. ReportError(T('Edit Denied'), '403 FORBIDDEN', undef,
  3051. $q->p(T('Editing not allowed: user, ip, or network is blocked.')),
  3052. $q->p(T('Contact the wiki administrator for more information.')),
  3053. $q->p(Ts('The rule %s matched for you.', $rule) . ' '
  3054. . Ts('See %s for more information.', GetPageLink($BannedHosts))));
  3055. } else {
  3056. ReportError(T('Edit Denied'), '403 FORBIDDEN', undef,
  3057. $q->p(Ts('Editing not allowed: %s is read-only.', NormalToFree($id))));
  3058. }
  3059. }
  3060. }
  3061. sub UserCanEdit {
  3062. my ($id, $editing, $comment) = @_;
  3063. return 0 if $id eq 'SampleUndefinedPage' or $id eq T('SampleUndefinedPage')
  3064. or $id eq 'Sample_Undefined_Page' or $id eq T('Sample_Undefined_Page');
  3065. return 1 if UserIsAdmin();
  3066. return 0 if $id ne '' and IsFile(GetLockedPageFile($id));
  3067. return 0 if $LockOnCreation{$id} and not IsFile(GetPageFile($id)); # new page
  3068. return 1 if UserIsEditor();
  3069. return 0 if not $EditAllowed or IsFile($NoEditFile);
  3070. return 0 if $editing and UserIsBanned(); # this call is more expensive
  3071. return 0 if $EditAllowed >= 2 and (not $CommentsPattern or $id !~ /$CommentsPattern/);
  3072. return 1 if $EditAllowed >= 3 and GetParam('recent_edit', '') ne 'on' # disallow minor comments
  3073. and ($comment or (GetParam('aftertext', '') and not GetParam('text', '')));
  3074. return 0 if $EditAllowed >= 3;
  3075. return 1;
  3076. }
  3077. sub UserIsBanned {
  3078. return 0 if GetParam('action', '') eq 'password'; # login is always ok
  3079. my $host = $q->remote_addr();
  3080. foreach (split(/\n/, GetPageContent($BannedHosts))) {
  3081. if (/^\s*([^#]\S+)/) { # all lines except empty lines and comments, trim whitespace
  3082. my $regexp = $1;
  3083. return $regexp if ($host =~ /$regexp/i);
  3084. }
  3085. }
  3086. return 0;
  3087. }
  3088. sub UserIsAdmin {
  3089. return UserHasPassword(GetParam('pwd', ''), $AdminPass);
  3090. }
  3091. sub UserIsEditor {
  3092. return 1 if UserIsAdmin(); # Admin includes editor
  3093. return UserHasPassword(GetParam('pwd', ''), $EditPass);
  3094. }
  3095. sub UserHasPassword {
  3096. my ($pwd, $pass) = @_;
  3097. return 0 unless $pass;
  3098. if ($PassHashFunction ne '') {
  3099. no strict 'refs'; # TODO this is kept for compatibility. Feel free to remove it later (comment written on 2015-07-14)
  3100. $pwd = $PassHashFunction->($pwd . $PassSalt);
  3101. }
  3102. foreach (split(/\s+/, $pass)) {
  3103. return 1 if $pwd eq $_;
  3104. }
  3105. return 0;
  3106. }
  3107. sub BannedContent {
  3108. my $str = shift;
  3109. my @urls = $str =~ /$FullUrlPattern/g;
  3110. foreach (split(/\n/, GetPageContent($BannedContent))) {
  3111. next unless m/^\s*([^#]+?)\s*(#\s*(\d\d\d\d-\d\d-\d\d\s*)?(.*))?$/;
  3112. my ($regexp, $comment, $re) = ($1, $4, undef);
  3113. foreach my $url (@urls) {
  3114. eval { $re = qr/$regexp/i; };
  3115. if (defined($re) and $url =~ $re) {
  3116. return Tss('Rule "%1" matched "%2" on this page.', $regexp, $url) . ' '
  3117. . ($comment ? Ts('Reason: %s.', $comment) : T('Reason unknown.')) . ' '
  3118. . Ts('See %s for more information.', GetPageLink($BannedContent));
  3119. }
  3120. }
  3121. }
  3122. return 0;
  3123. }
  3124. sub SortIndex {
  3125. my ($A, $B) = ($a, $b);
  3126. my $aIsComment = $A =~ s/^$CommentsPrefix//;
  3127. $B =~ s/^$CommentsPrefix//;
  3128. return $aIsComment ? 1 : -1 if $A eq $B;
  3129. $A cmp $B;
  3130. }
  3131. sub DoIndex {
  3132. my $raw = GetParam('raw', 0);
  3133. my $match = GetParam('match', '');
  3134. my $limit = GetParam('n', '');
  3135. my @pages = ();
  3136. my @menu = ($q->label({-for=>'indexmatch'}, T('Filter:')) . ' '
  3137. . $q->textfield(-name=>'match', -id=>'indexmatch', -size=>20));
  3138. foreach my $data (@IndexOptions) {
  3139. my ($option, $text, $default, $sub) = @$data;
  3140. my $value = GetParam($option, $default); # HTML checkbox warning!
  3141. $value = 0 if GetParam('manual', 0) and $value ne 'on';
  3142. push(@pages, $sub->()) if $value;
  3143. push(@menu, $q->checkbox(-name=>$option, -checked=>$value, -label=>$text));
  3144. }
  3145. @pages = grep /$match/i, @pages if $match;
  3146. @pages = sort SortIndex @pages;
  3147. @pages = @pages[0 .. $limit - 1] if $limit;
  3148. if ($raw) {
  3149. print GetHttpHeader('text/plain'); # and ignore @menu
  3150. } else {
  3151. print GetHeader('', T('Index of all pages'));
  3152. push(@menu, GetHiddenValue('manual', 1) . $q->submit(-value=>T('Go!')));
  3153. push(@menu, $q->b(Ts('(for %s)', GetParam('lang', '')))) if GetParam('lang', '');
  3154. print $q->start_div({-class=>'content index'}),
  3155. GetFormStart(undef, 'get', 'index'), GetHiddenValue('action', 'index'),
  3156. $q->p(join($q->br(), @menu)), $q->end_form(),
  3157. $q->h2(Ts('%s pages found.', ($#pages + 1))), $q->start_p();
  3158. }
  3159. PrintPage($_) foreach (@pages);
  3160. print $q->end_p(), $q->end_div() unless $raw;
  3161. PrintFooter() unless $raw;
  3162. }
  3163. sub PrintPage {
  3164. my $id = shift;
  3165. my $lang = GetParam('lang', 0);
  3166. if ($lang) {
  3167. OpenPage($id);
  3168. my @languages = split(/,/, $Page{languages});
  3169. next if (@languages and not grep(/$lang/, @languages));
  3170. }
  3171. if (GetParam('raw', 0)) {
  3172. if (GetParam('search', '') and GetParam('context', 1)) {
  3173. print "title: $id\n\n"; # for near links without full search
  3174. } else {
  3175. print $id, "\n";
  3176. }
  3177. } else {
  3178. print GetPageOrEditLink($id, NormalToFree($id)), $q->br();
  3179. }
  3180. }
  3181. sub AllPagesList {
  3182. my $refresh = GetParam('refresh', 0);
  3183. return @IndexList if @IndexList and not $refresh;
  3184. SetParam('refresh', 0) if $refresh;
  3185. return @IndexList if not $refresh and IsFile($IndexFile) and ReadIndex();
  3186. # If open fails just refresh the index
  3187. RefreshIndex();
  3188. return @IndexList;
  3189. }
  3190. sub ReadIndex {
  3191. my ($status, $rawIndex) = ReadFile($IndexFile); # not fatal
  3192. if ($status) {
  3193. @IndexList = split(/ /, $rawIndex);
  3194. %IndexHash = map {$_ => 1} @IndexList;
  3195. return @IndexList;
  3196. }
  3197. return;
  3198. }
  3199. sub WriteIndex {
  3200. WriteStringToFile($IndexFile, join(' ', @IndexList));
  3201. }
  3202. sub RefreshIndex {
  3203. @IndexList = ();
  3204. %IndexHash = ();
  3205. # If file exists and cannot be changed, error!
  3206. my $locked = RequestLockDir('index', undef, undef, IsFile($IndexFile));
  3207. foreach (Glob("$PageDir/*.pg"), Glob("$PageDir/.*.pg")) {
  3208. next unless m|/.*/(.+)\.pg$|;
  3209. my $id = $1;
  3210. push(@IndexList, $id);
  3211. $IndexHash{$id} = 1;
  3212. }
  3213. WriteIndex() if $locked;
  3214. ReleaseLockDir('index') if $locked;
  3215. }
  3216. sub AddToIndex {
  3217. my ($id) = @_;
  3218. $IndexHash{$id} = 1;
  3219. @IndexList = sort(keys %IndexHash);
  3220. WriteIndex();
  3221. }
  3222. sub DoSearch {
  3223. my $string = shift || GetParam('search', '');
  3224. my $re = UnquoteHtml($string);
  3225. return DoIndex() if $string eq '';
  3226. eval { qr/$re/ } or $re = quotemeta($re);
  3227. my $replacement = GetParam('replace', undef);
  3228. my $raw = GetParam('raw', '');
  3229. my @results;
  3230. if ($replacement or GetParam('delete', 0)) {
  3231. return unless UserIsAdminOrError();
  3232. if (GetParam('preview', '')) { # Preview button was used
  3233. print GetHeader('', Ts('Preview: %s', $string . " &#x2192; " . $replacement));
  3234. print $q->start_div({-class=>'content replacement'});
  3235. print GetFormStart(undef, 'post', 'replace');
  3236. print GetHiddenValue('search', $string);
  3237. print GetHiddenValue('replace', $replacement);
  3238. print GetHiddenValue('delete', GetParam('delete', 0));
  3239. print $q->submit(-value=>T('Go!')) . $q->end_form();
  3240. @results = ReplaceAndDiff($re, UnquoteHtml($replacement));
  3241. } else {
  3242. print GetHeader('', Ts('Replaced: %s', $string . " &#x2192; " . $replacement));
  3243. print $q->start_div({-class=>'content replacement'});
  3244. @results = ReplaceAndSave($re, UnquoteHtml($replacement));
  3245. foreach (@results) {
  3246. PrintSearchResult($_, quotemeta($replacement || $re)); # the replacement is not a valid regex
  3247. }
  3248. }
  3249. } else {
  3250. if ($raw) {
  3251. print GetHttpHeader('text/plain');
  3252. print RcTextItem('title', Ts('Search for: %s', $string)), RcTextItem('date', TimeToText($Now)),
  3253. RcTextItem('link', $q->url(-path_info=>1, -query=>1)), "\n" if GetParam('context', 1);
  3254. } else {
  3255. print GetHeader('', Ts('Search for: %s', $string)), $q->start_div({-class=>'content search'});
  3256. print $q->p({-class=>'links'}, SearchMenu($string));
  3257. }
  3258. @results = SearchTitleAndBody($re, \&PrintSearchResult, SearchRegexp($re));
  3259. }
  3260. print SearchResultCount($#results + 1), $q->end_div() unless $raw;
  3261. PrintFooter() unless $raw;
  3262. }
  3263. sub SearchMenu {
  3264. return ScriptLink('action=rc;rcfilteronly=' . UrlEncode(shift),
  3265. T('View changes for these pages'));
  3266. }
  3267. sub SearchResultCount { $q->p({-class=>'result'}, Ts('%s pages found.', (shift))); }
  3268. sub PageIsUploadedFile {
  3269. my $id = shift;
  3270. return if $OpenPageName eq $id;
  3271. if ($IndexHash{$id}) {
  3272. my $file = GetPageFile($id);
  3273. open(my $FILE, '<:encoding(UTF-8)', encode_utf8($file))
  3274. or ReportError(Ts('Cannot open %s', GetPageFile($id))
  3275. . ": $!", '500 INTERNAL SERVER ERROR');
  3276. while (defined($_ = <$FILE>) and $_ !~ /^text: /) {
  3277. } # read lines until we get to the text key
  3278. close $FILE;
  3279. return unless length($_) > 6;
  3280. return TextIsFile(substr($_, 6)); # pass "#FILE image/png\n" to the test
  3281. }
  3282. }
  3283. sub SearchTitleAndBody {
  3284. my ($regex, $func, @args) = @_;
  3285. my @found;
  3286. my $lang = GetParam('lang', '');
  3287. foreach my $id (Filtered($regex, AllPagesList())) {
  3288. my $name = NormalToFree($id);
  3289. my ($text) = PageIsUploadedFile($id); # set to mime-type if this is an uploaded file
  3290. local ($OpenPageName, %Page); # this is local!
  3291. if (not $text) { # not uploaded file, therefore allow searching of page body
  3292. OpenPage($id); # this opens a page twice if it is not uploaded, but that's ok
  3293. if ($lang) {
  3294. my @languages = split(/,/, $Page{languages});
  3295. next if (@languages and not grep(/$lang/, @languages));
  3296. }
  3297. $text = $Page{text};
  3298. }
  3299. if (SearchString($regex, $name . "\n" . $text)) { # the real search code
  3300. push(@found, $id);
  3301. $func->($id, @args) if $func;
  3302. }
  3303. }
  3304. return @found;
  3305. }
  3306. sub Filtered { # this is overwriten in extensions such as tags.pl
  3307. my ($string, @pages) = @_;
  3308. my $match = GetParam('match', '');
  3309. @pages = grep /$match/i, @pages if $match;
  3310. return @pages;
  3311. }
  3312. sub SearchString {
  3313. my ($string, $data) = @_;
  3314. my @strings = grep /./, $string =~ /\"([^\"]+)\"|(\S+)/g; # skip null entries
  3315. foreach my $str (@strings) {
  3316. return 0 unless ($data =~ /$str/i);
  3317. }
  3318. return 1;
  3319. }
  3320. sub SearchRegexp {
  3321. my $regexp = join '|', map { index($_, '|') == -1 ? $_ : "($_)" }
  3322. grep /./, shift =~ /\"([^\"]+)\"|(\S+)/g; # this acts as OR
  3323. $regexp =~ s/\\s/[[:space:]]/g;
  3324. return $regexp;
  3325. }
  3326. sub PrintSearchResult {
  3327. my ($name, $regex) = @_;
  3328. return PrintPage($name) if not GetParam('context', 1);
  3329. OpenPage($name); # should be open already, just making sure!
  3330. my $text = $Page{text};
  3331. my ($type) = TextIsFile($text); # MIME type if an uploaded file
  3332. my %entry;
  3333. # get the page, filter it, remove all tags
  3334. $text =~ s/$FS//g; # Remove separators (paranoia)
  3335. $text =~ s/[\s]+/ /g; # Shrink whitespace
  3336. $text =~ s/([-_=\\*\\.]){10,}/$1$1$1$1$1/g ; # e.g. shrink "----------"
  3337. $entry{title} = $name;
  3338. $entry{description} = $type || SearchHighlight(QuoteHtml(SearchExtract($text, $regex)), QuoteHtml($regex));
  3339. $entry{size} = int((length($text) / 1024) + 1) . 'K';
  3340. $entry{'last-modified'} = TimeToText($Page{ts});
  3341. $entry{username} = $Page{username};
  3342. PrintSearchResultEntry(\%entry);
  3343. }
  3344. sub PrintSearchResultEntry {
  3345. my %entry = %{(shift)}; # get value from reference
  3346. if (GetParam('raw', 0)) {
  3347. $entry{generator} = GetAuthor($entry{username});
  3348. foreach my $key (qw(title description size last-modified generator username)) {
  3349. print RcTextItem($key, $entry{$key});
  3350. }
  3351. print RcTextItem('link', "$ScriptName?$entry{title}"), "\n";
  3352. } else {
  3353. my $author = GetAuthorLink($entry{username});
  3354. $author ||= $entry{generator};
  3355. my $id = $entry{title};
  3356. my ($class, $resolved, $title, $exists) = ResolveId($id);
  3357. my $text = NormalToFree($id);
  3358. my $result = $q->span({-class=>'result'}, ScriptLink(UrlEncode($resolved), $text, $class, undef, $title));
  3359. my $description = $entry{description};
  3360. $description = $q->br() . $description if $description;
  3361. my $info = $entry{size};
  3362. $info .= ' - ' if $info;
  3363. $info .= T('last updated') . ' ' . $entry{'last-modified'} if $entry{'last-modified'};
  3364. $info .= ' ' . T('by') . ' ' . $author if $author;
  3365. $info = $q->br() . $q->span({-class=>'info'}, $info) if $info;
  3366. print $q->p($result, $description, $info);
  3367. }
  3368. }
  3369. sub SearchHighlight {
  3370. my ($data, $regex) = @_;
  3371. $data =~ s/($regex)/<strong>$1<\/strong>/gi unless GetParam('raw');
  3372. return $data;
  3373. }
  3374. sub SearchExtract {
  3375. my ($data, $regex) = @_;
  3376. my ($snippetlen, $maxsnippets) = (100, 4); # these seem nice.
  3377. # show a snippet from the beginning of the document
  3378. my $j = index($data, ' ', $snippetlen); # end on word boundary
  3379. my $t = substr($data, 0, $j);
  3380. my $result = $t . ' . . .';
  3381. $data = substr($data, $j); # to avoid rematching
  3382. my $jsnippet = 0 ;
  3383. while ($jsnippet < $maxsnippets and $data =~ m/($regex)/i) {
  3384. $jsnippet++;
  3385. if (($j = index($data, $1)) > -1 ) {
  3386. # get substr containing (start of) match, ending on word boundaries
  3387. my $start = index($data, ' ', $j - $snippetlen / 2);
  3388. $start = 0 if $start == -1;
  3389. my $end = index($data, ' ', $j + $snippetlen / 2);
  3390. $end = length($data) if $end == -1;
  3391. $t = substr($data, $start, $end - $start);
  3392. $result .= $t . ' . . .';
  3393. # truncate text to avoid rematching the same string.
  3394. $data = substr($data, $end);
  3395. }
  3396. }
  3397. return $result;
  3398. }
  3399. sub ReplaceAndSave {
  3400. my ($from, $to) = @_;
  3401. RequestLockOrError(); # fatal
  3402. my @result = Replace($from, $to, 1, sub {
  3403. my ($id, $new) = @_;
  3404. Save($id, $new, $from . ' → ' . $to, 1);
  3405. });
  3406. ReleaseLock();
  3407. return @result;
  3408. }
  3409. sub ReplaceAndDiff {
  3410. my ($from, $to) = @_;
  3411. my @found = Replace($from, $to, 0, sub {
  3412. my ($id, $new) = @_;
  3413. print $q->h2(GetPageLink($id)), $q->div({-class=>'diff'}, ImproveDiff(DoDiff($Page{text}, $new)));
  3414. });
  3415. if (@found > GetParam('offset', 0) + GetParam('num', 10)) {
  3416. my $more = "search=" . UrlEncode($from) . ";preview=1"
  3417. . ";offset=" . (GetParam('num', 10) + GetParam('offset', 0))
  3418. . ";num=" . GetParam('num', 10);
  3419. $more .= ";replace=" . UrlEncode($to) if $to;
  3420. $more .= ";delete=1" unless $to;
  3421. print $q->p({-class=>'more'}, ScriptLink($more, T('More...'), 'more'));
  3422. }
  3423. return @found;
  3424. }
  3425. sub Replace {
  3426. my ($from, $to, $all, $func) = @_; # $func takes $id and $new text
  3427. my $lang = GetParam('lang', '');
  3428. my $num = GetParam('num', 10);
  3429. my $offset = GetParam('offset', 0);
  3430. my @result;
  3431. foreach my $id (AllPagesList()) {
  3432. OpenPage($id);
  3433. if ($lang) {
  3434. my @languages = split(/,/, $Page{languages});
  3435. next if (@languages and not grep(/$lang/, @languages));
  3436. }
  3437. $_ = $Page{text};
  3438. my $replacement = sub {
  3439. my ($o1, $o2, $o3, $o4, $o5, $o6, $o7, $o8, $o9) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
  3440. my $str = $to;
  3441. $str =~ s/\$([1-9])/'$o' . $1/eeg;
  3442. $str
  3443. };
  3444. if (s/$from/$replacement->()/egi) { # allows use of backreferences
  3445. push (@result, $id);
  3446. $func->($id, $_) if $all or @result > $offset and @result <= $offset + $num;
  3447. }
  3448. }
  3449. return @result;
  3450. }
  3451. sub DoPost {
  3452. my $id = FreeToNormal(shift);
  3453. UserCanEditOrDie($id);
  3454. # Lock before getting old page to prevent races
  3455. RequestLockOrError(); # fatal
  3456. OpenPage($id);
  3457. my $old = $Page{text};
  3458. my $string = UnquoteHtml(GetParam('text', undef));
  3459. $string =~ s/(\r|$FS)//g;
  3460. my ($type) = TextIsFile($string); # MIME type if an uploaded file
  3461. my $filename = GetParam('file', undef);
  3462. if (($filename or $type) and not $UploadAllowed and not UserIsAdmin()) {
  3463. ReportError(T('Only administrators can upload files.'), '403 FORBIDDEN');
  3464. }
  3465. my $comment = UnquoteHtml(GetParam('aftertext', undef));
  3466. $comment =~ s/(\r|$FS)//g;
  3467. if (defined $comment and $comment eq '') {
  3468. ReleaseLock();
  3469. return ReBrowsePage($id);
  3470. }
  3471. if ($filename) { # upload file
  3472. my $file = $q->upload('file');
  3473. if (not $file and $q->cgi_error) {
  3474. ReportError(Ts('Transfer Error: %s', $q->cgi_error), '500 INTERNAL SERVER ERROR');
  3475. }
  3476. ReportError(T('Browser reports no file info.'), '500 INTERNAL SERVER ERROR') unless $q->uploadInfo($filename);
  3477. $type = $q->uploadInfo($filename)->{'Content-Type'};
  3478. ReportError(T('Browser reports no file type.'), '415 UNSUPPORTED MEDIA TYPE') unless $type;
  3479. local $/ = undef; # Read complete files
  3480. my $content = <$file>; # Apparently we cannot count on <$file> to always work within the eval!?
  3481. my $encoding = substr($content, 0, 2) eq "\x1f\x8b" ? 'gzip' : '';
  3482. eval { require MIME::Base64; $_ = MIME::Base64::encode($content) };
  3483. $string = "#FILE $type $encoding\n" . $_;
  3484. } else { # ordinary text edit
  3485. $string = AddComment($old, $comment) if defined $comment;
  3486. if ($comment and substr($string, 0, length($DeletedPage)) eq $DeletedPage) { # look ma, no regexp!
  3487. $string = substr($string, length($DeletedPage)); # undelete pages when adding a comment
  3488. }
  3489. $string .= "\n" if ($string !~ /\n$/); # add trailing newline
  3490. $string = RunMyMacros($string); # run macros on text pages only
  3491. }
  3492. my %allowed = map {$_ => 1} @UploadTypes;
  3493. if (@UploadTypes and $type and not $allowed{$type}) {
  3494. ReportError(Ts('Files of type %s are not allowed.', $type), '415 UNSUPPORTED MEDIA TYPE');
  3495. }
  3496. # Banned Content
  3497. my $summary = GetSummary();
  3498. if (not UserIsEditor()) {
  3499. my $rule = BannedContent(NormalToFree($id)) || BannedContent($string) || BannedContent($summary);
  3500. ReportError(T('Edit Denied'), '403 FORBIDDEN', undef, $q->p(T('The page contains banned text.')),
  3501. $q->p(T('Contact the wiki administrator for more information.')), $q->p($rule)) if $rule;
  3502. }
  3503. # rebrowse if no changes
  3504. my $oldrev = $Page{revision};
  3505. if (GetParam('Preview', '')) { # Preview button was used
  3506. ReleaseLock();
  3507. if (defined $comment) {
  3508. BrowsePage($id, 0, RunMyMacros($comment)); # show macros in preview
  3509. } else {
  3510. DoEdit($id, $string, 1);
  3511. }
  3512. return;
  3513. } elsif ($old eq $string) {
  3514. ReleaseLock(); # No changes -- just show the same page again
  3515. return ReBrowsePage($id);
  3516. } elsif ($oldrev == 0 and $string eq "\n") {
  3517. ReportError(T('No changes to be saved.'), '400 BAD REQUEST'); # don't fake page creation because of webdav
  3518. }
  3519. my $newAuthor = 0;
  3520. if ($oldrev) { # the first author (no old revision) is not considered to be "new"
  3521. $newAuthor = 1 if not $Page{username} or $Page{username} ne GetParam('username', '');
  3522. }
  3523. my $oldtime = $Page{ts};
  3524. my $myoldtime = GetParam('oldtime', ''); # maybe empty!
  3525. # Handle raw edits with the meta info on the first line
  3526. if (GetParam('raw', 0) == 2 and $string =~ /^([0-9]+).*\n((.*\n)*.*)/) {
  3527. $myoldtime = $1;
  3528. $string = $2;
  3529. }
  3530. my $generalwarning = 0;
  3531. if ($newAuthor and $oldtime ne $myoldtime and not defined $comment) {
  3532. if ($myoldtime) {
  3533. my ($ancestor) = GetTextAtTime($myoldtime);
  3534. if ($ancestor and $old ne $ancestor) {
  3535. my $new = MergeRevisions($string, $ancestor, $old);
  3536. if ($new) {
  3537. $string = $new;
  3538. if ($new =~ /^<<<<<<</m and $new =~ /^>>>>>>>/m) {
  3539. SetParam('msg', Ts('This page was changed by somebody else %s.',
  3540. CalcTimeSince($Now - $Page{ts}))
  3541. . ' ' . T('The changes conflict. Please check the page again.'));
  3542. } # else no conflict
  3543. } else {
  3544. $generalwarning = 1;
  3545. } # else merge revision didn't work
  3546. } # else nobody changed the page in the mean time (same text)
  3547. } else {
  3548. $generalwarning = 1;
  3549. } # no way to be sure since myoldtime is missing
  3550. } # same author or nobody changed the page in the mean time (same timestamp)
  3551. if ($generalwarning and ($Now - $Page{ts}) < 600) {
  3552. SetParam('msg', Ts('This page was changed by somebody else %s.',
  3553. CalcTimeSince($Now - $Page{ts}))
  3554. . ' ' . T('Please check whether you overwrote those changes.'));
  3555. }
  3556. Save($id, $string, $summary, (GetParam('recent_edit', '') eq 'on'), $filename);
  3557. ReleaseLock();
  3558. ReBrowsePage($id);
  3559. }
  3560. sub GetSummary {
  3561. my $text = GetParam('aftertext', '') || ($Page{revision} > 0 ? '' : GetParam('text', ''));
  3562. return '' if $text =~ /^#FILE /;
  3563. if ($SummaryDefaultLength and length($text) > $SummaryDefaultLength) {
  3564. $text = substr($text, 0, $SummaryDefaultLength);
  3565. $text =~ s/\s*\S*$/ . . ./;
  3566. }
  3567. my $summary = GetParam('summary', '') || $text; # not GetParam('summary', $text) work because '' is defined
  3568. $summary =~ s/$FS|[\r\n]+/ /g; # remove linebreaks and separator characters
  3569. $summary =~ s/\[$FullUrlPattern\s+(.*?)\]/$2/g; # fix common annoyance when copying text to summary
  3570. $summary =~ s/\[$FullUrlPattern\]//g;
  3571. $summary =~ s/\[\[$FreeLinkPattern\]\]/$1/g;
  3572. return UnquoteHtml($summary);
  3573. }
  3574. sub AddComment {
  3575. my ($string, $comment) = @_;
  3576. $comment =~ s/\r//g; # Remove "\r"-s (0x0d) from the string
  3577. $comment =~ s/\s+$//g; # Remove whitespace at the end
  3578. if ($comment ne '') {
  3579. my $author = GetParam('username', T('Anonymous'));
  3580. my $homepage = GetParam('homepage', '');
  3581. $homepage = 'http://' . $homepage if $homepage and $homepage !~ /^($UrlProtocols):/;
  3582. $author = "[$homepage $author]" if $homepage;
  3583. $string .= "\n----\n\n" if $string and $string ne "\n";
  3584. $string .= $comment . "\n\n"
  3585. . '-- ' . $author . ' ' . TimeToText($Now) . "\n\n";
  3586. }
  3587. return $string;
  3588. }
  3589. sub Save { # call within lock, with opened page
  3590. my ($id, $new, $summary, $minor, $upload) = @_;
  3591. my $user = GetParam('username', '');
  3592. my $revision = $Page{revision} + 1;
  3593. my $old = $Page{text};
  3594. my $olddiff = $Page{'diff-major'} == '1' ? $Page{'diff-minor'} : $Page{'diff-major'};
  3595. if ($revision == 1 and IsFile($IndexFile) and not Unlink($IndexFile)) { # regenerate index on next request
  3596. SetParam('msg', Ts('Cannot delete the index file %s.', $IndexFile)
  3597. . ' ' . T('Please check the directory permissions.')
  3598. . ' ' . T('Your changes were not saved.'));
  3599. return 0;
  3600. }
  3601. ReInit($id);
  3602. TouchIndexFile();
  3603. SaveKeepFile(); # deletes blocks, flags, diff-major, and diff-minor, and sets keep-ts
  3604. ExpireKeepFiles();
  3605. $Page{lastmajor} = $revision unless $minor;
  3606. $Page{lastmajorsummary} = $summary unless $minor;
  3607. @Page{qw(ts revision summary username minor text)} =
  3608. ($Now, $revision, $summary, $user, $minor, $new);
  3609. if ($UseDiff and $UseCache > 1 and $revision > 1 and not $upload and not TextIsFile($old)) {
  3610. UpdateDiffs($old, $new, $olddiff); # sets diff-major and diff-minor
  3611. }
  3612. my $languages;
  3613. $languages = GetLanguages($new) unless $upload;
  3614. $Page{languages} = $languages;
  3615. SavePage();
  3616. if ($revision == 1 and $LockOnCreation{$id}) {
  3617. WriteStringToFile(GetLockedPageFile($id), 'LockOnCreation');
  3618. }
  3619. my $host = $q->remote_addr();
  3620. WriteRcLog($id, $summary, $minor, $revision, $user, $host, $languages, GetCluster($new));
  3621. AddToIndex($id) if ($revision == 1);
  3622. }
  3623. sub TouchIndexFile {
  3624. my $ts = time;
  3625. utime $ts, $ts, $IndexFile;
  3626. $LastUpdate = $Now = $ts;
  3627. }
  3628. sub GetLanguages {
  3629. my $text = shift;
  3630. my %result;
  3631. for my $lang (keys %Languages) {
  3632. my @matches = $text =~ /$Languages{$lang}/gi;
  3633. $result{$lang} = @matches if @matches >= $LanguageLimit;
  3634. }
  3635. return join(',', sort { $result{$b} <=> $result{$a} } keys %result);
  3636. }
  3637. sub GetLanguage { # the first language, or the default language
  3638. return ((split /,/, GetLanguages(@_))[0] or $CurrentLanguage);
  3639. }
  3640. sub GetCluster {
  3641. $_ = shift;
  3642. return '' unless $PageCluster;
  3643. return $1 if ($WikiLinks && /^$LinkPattern\n/)
  3644. or ($FreeLinks && /^\[\[$FreeLinkPattern\]\]\n/);
  3645. }
  3646. sub MergeRevisions { # merge change from file2 to file3 into file1
  3647. my ($file1, $file2, $file3) = @_;
  3648. my ($name1, $name2, $name3) = ("$TempDir/file1", "$TempDir/file2", "$TempDir/file3");
  3649. CreateDir($TempDir);
  3650. RequestLockDir('merge') or return T('Could not get a lock to merge!');
  3651. WriteStringToFile($name1, $file1);
  3652. WriteStringToFile($name2, $file2);
  3653. WriteStringToFile($name3, $file3);
  3654. my ($you, $ancestor, $other) = (T('you'), T('ancestor'), T('other'));
  3655. my $output = decode_utf8(`diff3 -m -L \Q$you\E -L \Q$ancestor\E -L \Q$other\E -- \Q$name1\E \Q$name2\E \Q$name3\E`);
  3656. ReleaseLockDir('merge'); # don't unlink temp files--next merge will just overwrite.
  3657. return $output;
  3658. }
  3659. # Note: all diff and recent-list operations should be done within locks.
  3660. sub WriteRcLog {
  3661. my ($id, $summary, $minor, $revision, $username, $host, $languages, $cluster) = @_;
  3662. my $line = join($FS, $Now, $id, $minor, $summary, $host,
  3663. $username, $revision, $languages, $cluster);
  3664. AppendStringToFile($RcFile, $line . "\n");
  3665. }
  3666. sub UpdateDiffs { # this could be optimized, but isn't frequent enough
  3667. my ($old, $new, $olddiff) = @_;
  3668. $Page{'diff-minor'} = GetDiff($old, $new); # create new diff-minor
  3669. # 1 is a special value for GetCacheDiff telling it to use diff-minor
  3670. $Page{'diff-major'} = $Page{lastmajor} == $Page{revision} ? 1 : $olddiff;
  3671. }
  3672. sub DoMaintain {
  3673. print GetHeader('', T('Run Maintenance')), $q->start_div({-class=>'content maintain'});
  3674. my $fname = "$DataDir/maintain";
  3675. if (not UserIsAdmin()) {
  3676. if (IsFile($fname) and $Now - Modified($fname) < 12 * 60 * 60) {
  3677. print $q->p(T('Maintenance not done.') . ' ' . T('(Maintenance can only be done once every 12 hours.)')
  3678. . ' ', T('Remove the "maintain" file or wait.')), $q->end_div();
  3679. PrintFooter();
  3680. return;
  3681. }
  3682. }
  3683. print '<p>', T('Expiring keep files and deleting pages marked for deletion');
  3684. ExpireAllKeepFiles();
  3685. print '</p>';
  3686. RequestLockOrError();
  3687. print $q->p(T('Main lock obtained.'));
  3688. print $q->p(Ts('Moving part of the %s log file.', $RCName));
  3689. # Determine the number of days to go back, default is largest of @RcDays
  3690. my $days = 0;
  3691. foreach (@RcDays) {
  3692. $days = $_ if $_ > $days;
  3693. }
  3694. my $starttime = $Now - $days * 86400; # 24*60*60
  3695. # Read the current file
  3696. my ($status, $data) = ReadFile($RcFile);
  3697. if (not $status) {
  3698. print $q->p($q->strong(Ts('Could not open %s log file', $RCName) . ':') . ' ' . $RcFile),
  3699. $q->p(T('Error was') . ':'), $q->pre($!), $q->p(T('Note: This error is normal if no changes have been made.'));
  3700. } else {
  3701. WriteStringToFile($RcFile . '.old', $data);
  3702. }
  3703. # Move the old stuff from rc to temp
  3704. my @rc = split(/\n/, $data);
  3705. my @tmp = ();
  3706. my $line;
  3707. my $changed = 0;
  3708. while ($line = shift(@rc)) {
  3709. my ($ts, $id, $minor, $summary, $host, @rest) = split(/$FS/, $line);
  3710. last if $ts >= $starttime;
  3711. push(@tmp, join($FS, $ts, $id, $minor, $summary, 'Anonymous', @rest));
  3712. $changed = 1;
  3713. }
  3714. unshift(@rc, $line) if $line; # this one ended the loop
  3715. print $q->p(Ts('Moving %s log entries.', scalar(@tmp)));
  3716. AppendStringToFile($RcOldFile, join("\n", @tmp) . "\n") if @tmp;
  3717. # remove IP numbers from all but the last few days
  3718. $starttime = $Now - $KeepHostDays * 86400; # 24*60*60
  3719. @tmp = ();
  3720. while ($line = shift(@rc)) {
  3721. my ($ts, $id, $minor, $summary, $host, @rest) = split(/$FS/, $line);
  3722. last if $ts >= $starttime;
  3723. push(@tmp, join($FS, $ts, $id, $minor, $summary, 'Anonymous', @rest));
  3724. $changed = 1;
  3725. }
  3726. unshift(@rc, $line) if $line; # this one ended the loop
  3727. unshift(@rc, @tmp) if @tmp;
  3728. print $q->p(Ts('Removing IP numbers from %s log entries.', scalar(@tmp)));
  3729. WriteStringToFile($RcFile, @rc ? join("\n", @rc) . "\n" : '') if $changed;
  3730. if (opendir(DIR, $RssDir)) { # cleanup if they should expire anyway
  3731. foreach (readdir(DIR)) {
  3732. Unlink("$RssDir/$_") if $Now - Modified($_) > $RssCacheHours * 3600;
  3733. }
  3734. closedir DIR;
  3735. }
  3736. foreach my $func (@MyMaintenance) {
  3737. $func->();
  3738. }
  3739. WriteStringToFile($fname, 'Maintenance done at ' . TimeToText($Now));
  3740. ReleaseLock();
  3741. print $q->p(T('Main lock released.')), $q->end_div();
  3742. PrintFooter();
  3743. }
  3744. sub PageDeletable {
  3745. return unless $KeepDays;
  3746. my $expirets = $Now - ($KeepDays * 86400); # 24*60*60
  3747. return 0 if $Page{ts} >= $expirets;
  3748. return PageMarkedForDeletion();
  3749. }
  3750. sub PageMarkedForDeletion {
  3751. # Only pages explicitly marked for deletion or whitespace-only pages
  3752. # are deleted; taking into account the very rare possiblity of a
  3753. # read error and the page text being undefined.
  3754. return 1 if defined $Page{text} and $Page{text} =~ /^\s*$/;
  3755. return $DeletedPage && substr($Page{text}, 0, length($DeletedPage)) eq $DeletedPage;
  3756. }
  3757. sub DeletePage { # Delete must be done inside locks.
  3758. my $id = shift;
  3759. ValidIdOrDie($id);
  3760. AppendStringToFile($DeleteFile, "$id\n");
  3761. foreach my $name (GetPageFile($id), GetKeepFiles($id), GetKeepDir($id), GetLockedPageFile($id), $IndexFile) {
  3762. Unlink($name) if IsFile($name);
  3763. RemoveDir($name) if IsDir($name);
  3764. }
  3765. ReInit($id);
  3766. delete $IndexHash{$id};
  3767. @IndexList = sort(keys %IndexHash);
  3768. return ''; # no error
  3769. }
  3770. sub DoEditLock {
  3771. return unless UserIsAdminOrError();
  3772. print GetHeader('', T('Set or Remove global edit lock'));
  3773. my $fname = "$NoEditFile";
  3774. if (GetParam("set", 1)) {
  3775. WriteStringToFile($fname, 'editing locked.');
  3776. } else {
  3777. Unlink($fname);
  3778. }
  3779. utime time, time, $IndexFile; # touch index file
  3780. print $q->p(IsFile($fname) ? T('Edit lock created.') : T('Edit lock removed.'));
  3781. PrintFooter();
  3782. }
  3783. sub DoPageLock {
  3784. return unless UserIsAdminOrError();
  3785. print GetHeader('', T('Set or Remove page edit lock'));
  3786. my $id = GetParam('id', '');
  3787. ValidIdOrDie($id);
  3788. my $fname = GetLockedPageFile($id);
  3789. if (GetParam('set', 1)) {
  3790. WriteStringToFile($fname, 'editing locked.');
  3791. } else {
  3792. Unlink($fname);
  3793. }
  3794. utime time, time, $IndexFile; # touch index file
  3795. print $q->p(IsFile($fname) ? Ts('Lock for %s created.', GetPageLink($id))
  3796. : Ts('Lock for %s removed.', GetPageLink($id)));
  3797. PrintFooter();
  3798. }
  3799. sub DoShowVersion {
  3800. print GetHeader('', T('Displaying Wiki Version')), $q->start_div({-class=>'content version'});
  3801. print $WikiDescription, $q->p($q->server_software()),
  3802. $q->p(sprintf('Perl v%vd', $^V)),
  3803. $q->p($ENV{MOD_PERL} ? $ENV{MOD_PERL} : "no mod_perl"), $q->p('CGI: ', $CGI::VERSION),
  3804. $q->p('LWP::UserAgent ', eval { local $SIG{__DIE__}; require LWP::UserAgent; $LWP::UserAgent::VERSION; }),
  3805. $q->p('XML::RSS: ', eval { local $SIG{__DIE__}; require XML::RSS; $XML::RSS::VERSION; }),
  3806. $q->p('XML::Parser: ', eval { local $SIG{__DIE__}; $XML::Parser::VERSION; });
  3807. print $q->p('diff: ' . (`diff --version` || $!)), $q->p('diff3: ' . (`diff3 --version` || $!)) if $UseDiff;
  3808. print $q->end_div();
  3809. PrintFooter();
  3810. }
  3811. sub DoDebug {
  3812. print GetHeader('', T('Debugging Information')),
  3813. $q->start_div({-class=>'content debug'});
  3814. foreach my $func (@Debugging) { $func->() }
  3815. print $q->end_div();
  3816. PrintFooter();
  3817. }
  3818. sub DoSurgeProtection {
  3819. return unless $SurgeProtection;
  3820. my $name = GetParam('username', $q->remote_addr());
  3821. return unless $name;
  3822. ReadRecentVisitors();
  3823. AddRecentVisitor($name);
  3824. if (RequestLockDir('visitors')) { # not fatal
  3825. WriteRecentVisitors();
  3826. ReleaseLockDir('visitors');
  3827. if (DelayRequired($name)) {
  3828. ReportError(Ts('Too many connections by %s', $name)
  3829. . ': ' . Tss('Please do not fetch more than %1 pages in %2 seconds.',
  3830. $SurgeProtectionViews, $SurgeProtectionTime),
  3831. '503 SERVICE UNAVAILABLE');
  3832. }
  3833. } elsif (GetParam('action', '') ne 'unlock') {
  3834. ReportError(Ts('Could not get %s lock', 'visitors') . ': ' . Ts('Check whether the web server can create the directory %s and whether it can create files in it.', $TempDir), '503 SERVICE UNAVAILABLE');
  3835. }
  3836. }
  3837. sub DelayRequired {
  3838. my $name = shift;
  3839. my @entries = @{$RecentVisitors{$name}};
  3840. my $ts = $entries[$SurgeProtectionViews];
  3841. return ($Now - $ts) < $SurgeProtectionTime;
  3842. }
  3843. sub AddRecentVisitor {
  3844. my $name = shift;
  3845. my $value = $RecentVisitors{$name};
  3846. my @entries = ($Now);
  3847. push(@entries, @{$value}) if $value;
  3848. $RecentVisitors{$name} = \@entries;
  3849. }
  3850. sub ReadRecentVisitors {
  3851. my ($status, $data) = ReadFile($VisitorFile);
  3852. %RecentVisitors = ();
  3853. return unless $status;
  3854. foreach (split(/\n/, $data)) {
  3855. my @entries = split /$FS/;
  3856. my $name = shift(@entries);
  3857. $RecentVisitors{$name} = \@entries if $name;
  3858. }
  3859. }
  3860. sub WriteRecentVisitors {
  3861. my $data = '';
  3862. my $limit = $Now - $SurgeProtectionTime;
  3863. foreach my $name (keys %RecentVisitors) {
  3864. my @entries = @{$RecentVisitors{$name}};
  3865. if ($entries[0] >= $limit) { # if the most recent one is too old, do not keep
  3866. $data .= join($FS, $name, @entries[0 .. $SurgeProtectionViews - 1]) . "\n";
  3867. }
  3868. }
  3869. WriteStringToFile($VisitorFile, $data);
  3870. }
  3871. sub TextIsFile { $_[0] =~ /^#FILE (\S+) ?(\S+)?\n/; }
  3872. sub AddModuleDescription { # cannot use $q here because this is module init time
  3873. my ($filename, $page, $dir, $tag) = @_;
  3874. my $src = "https://alexschroeder.ch/cgit/oddmuse/tree/modules/$dir" . UrlEncode($filename) . ($tag ? '?' . $tag : '');
  3875. my $doc = 'https://www.oddmuse.org/wiki/' . UrlEncode(FreeToNormal($page));
  3876. $ModulesDescription .= "<p><a href=\"$src\">" . QuoteHtml($filename) . "</a>" . ($tag ? " ($tag)" : '');
  3877. $ModulesDescription .= T(', see') . " <a href=\"$doc\">" . QuoteHtml($page) . "</a>" if $page;
  3878. $ModulesDescription .= "</p>";
  3879. }
  3880. DoWikiRequest() if $RunCGI and not exists $ENV{MOD_PERL}; # Do everything.
  3881. 1; # In case we are loaded from elsewhere