package Labyrinth::Plugin::Wiki::Text;
use warnings;
use strict;
use vars qw($VERSION);
$VERSION = '1.04';
=head1 NAME
Labyrinth::Plugin::Wiki::Text - Wiki text handler for Labyrinth framework.
=head1 DESCRIPTION
Contains all the Wiki text rendering code for Labyrinth.
=cut
# -------------------------------------
# Library Modules
use base qw(Labyrinth::Plugin::Base);
use Labyrinth::Audit;
use Labyrinth::DBUtils;
use Labyrinth::MLUtils;
use Labyrinth::Support;
use Labyrinth::Users;
use Labyrinth::Variables;
# -------------------------------------
# Variables
# preset with restricted pages
my %wiki_links = map {$_ => 1} qw(People Login Search RecentChanges);
my ($LinkPattern,$SitePattern,$UrlPattern,$UriPattern,$MailPattern,$SendPattern);
# HTML tag lists
# Single tags (that do not require a closing /tag)
my @HtmlSingle = qw(br hr);
# Tags that must be in <tag> ... </tag> pairs:
my @HtmlPairs = ( qw(b i p u h1 h2 h3 h4 h5 h6 code em strike strong blockquote ol ul li dt dd tr td th),
@HtmlSingle); # All singles can also be pairs
# -------------------------------------
# Public Methods
=head1 PUBLIC INTERFACE METHODS
=over 4
=item Render
Controls the process of rendering a given page.
=item InitLinkPatterns
Prepares patterns used to translate wiki links into HTML links.
=item Wiki2HTML
Translate WikiFormat into XHTML.
=item CommonMarkup
Looks for and translates common WikiFormat markup into XHTML.
=item WikiLink
Looks for and translates WikiFormat links into XHTML.
=item WikiHeading
Translate WikiFormat heading into XHTML.
=cut
sub Render {
my $self = shift;
my $hash = shift;
my $title = $cgiparams{pagename};
my $content = $hash->{content};
InitLinkPatterns() unless($LinkPattern);
$content = Wiki2HTML($content);
# reposition top level heading
if($content =~ s!^<h1>(.*?)</h1>!!) {
$title = $1;
}
return $title,$content;
}
sub InitLinkPatterns {
my $UpperLetter = '[A-Z\xc0-\xde]';
my $LowerLetter = '[a-z\xdf-\xff]';
my $AnyLetter = '[A-Za-z\xc0-\xff_0-9\$]';
my $AnyString = '[A-Za-z\xc0-\xff_0-9 \-\&\'~.,\?\(\)\"!\$:\/]';
# Main link pattern: lowercase between uppercase, then anything
my $LpA = $UpperLetter . $AnyLetter . '*';
my $LpB = $AnyLetter . $AnyString . '*';
my $LpC = $AnyLetter . '*:' . $AnyString . '*';
$LinkPattern = qr!\[\[($LpA|$LpC)\]\]!;
$SitePattern = qr!\[\[($LpA|$LpC)\|($LpB)\]\]!;
$UrlPattern = qr!\[($settings{urlregex})\]!;
$UriPattern = qr!\[($settings{urlregex})[ \|]($LpB)\]!;
$MailPattern = qr!\[(?:mailto:)?($settings{emailregex})\]!;
$SendPattern = qr!\[(?:mailto:)?($settings{emailregex})[ |]($LpB)\]!;
}
sub Wiki2HTML {
my ($text) = @_;
my (@stack, $code, $oldcode, $parse);
my $depth = 0;
my $html = '';
$code = 'p'; # we assume a paragraph starts
$text =~ s/\r\n?/\n/g;
for (split(/\n/, $text)) { # Process lines one-at-a-time
$_ .= "\n";
$parse = 2;
if (s/^(\*+)/<li>/) {
$code = "ul";
$depth = length $1;
} elsif (s/^(\#+)/<li>/) {
$code = "ol";
$depth = length $1;
} elsif (s/^![ \t]//) {
$code = "pre";
$depth = 1;
$parse = 0;
} elsif (s/^([ \t]{2})//) {
$code = "pre";
$depth = 1;
$parse = 1;
} elsif (s/^(\" )//) {
$code = "blockquote";
$depth = 1;
} else {
$code = "p";
$depth = 0;
}
while (@stack > $depth) { # Close tags as needed
$html .= '</' . pop(@stack) . ">\n";
}
if ($depth > 0) {
# $depth = $IndentLimit if ($depth > $IndentLimit);
if (@stack) { # Non-empty stack
$oldcode = pop(@stack);
if ($oldcode ne $code) {
$html .= "</$oldcode><$code>\n";
}
push(@stack, $code);
}
while (@stack < $depth) {
push(@stack, $code);
$html .= "<$code>\n";
}
}
if($code eq 'pre') {
s!^\s*$!<br />\n!; # Blank lines become new lines
} else {
s!^\s*$!<p>!; # Blank lines become new paragraphs
}
$html .= CommonMarkup($_, $parse);
}
while (@stack > 0) { # Clear stack
$html .= '</' . pop(@stack) . ">\n";
}
$html = process_html($html,0,1);
# $html =~ s!<p>(.*?)\s*<(ul|ol|h[1-6]|pre|p)>!<p>$1</p>\n<$2>!gs; # close <p>'s.
# $html =~ s!<p>(.*?)\s*$!<p>$1</p>!gs; # close final <p>.
# $html =~ s!\s*</p>\s*</p>!</p>!gs; # remove extra close paragraphs
# $html =~ s!<p>\s*</p>!!gs; # remove black paragraphs
# $html =~ s/(\s|<p>)*<p>\s*/\n<p>/gs; # multiple blank lines fold into one.
# $html =~ s/\s*<p>\s*<(ul|ol|h[1-6]|pre)/\n<$1/gs; # remove unnecessary <p>'s.
# $html =~ s!([^>\s]+)\s*<p>!$1</p>\n<p>!gs; # close paragraphs.
# $html =~ s!\s*</p>\s*<p!</p>\n<p!gs; # separate paragraphs for readability.
LogDebug("html=[$html]");
return $html;
}
# 2 = Full parser
# 1 = Link only parsing
# 0 = no parsing
sub CommonMarkup {
my ($text, $parse) = @_;
local $_ = $text;
if ($parse > 1) {
s!\<pre\>((.|\n)*?)\<\/pre\>!<pre>$1</pre>!ig;
s!\<code\>((.|\n)*?)\<\/code\>!<code>$1</code>!ig;
my $t;
for $t (@HtmlPairs) {
s!\<$t(\s[^<>]+?)?\>(.*?)\<\/$t\>!<$t$1>$2<\/$t>!gis;
}
for $t (@HtmlSingle) {
s!\<$t(\s[^<>]+?)?\>!<$t$1>!gi;
}
# The quote markup patterns avoid overlapping tags (with 5 quotes)
# by matching the inner quotes for the strong pattern.
s/!!(.*?)!!/<code>$1<\/code>/g; #'
s/('*)'''(.*?)'''/$1<strong>$2<\/strong>/g; #'
s/''(.*?)''/<em>$1<\/em>/g;
s/(^|\n)\s*(\=+)\s+([^\n]+)\s+\=+/WikiHeading($1, $2, $3)/geo;
s!\<br\>!<br />!g;
s!----+!<hr noshade="noshade" size="1" />!g;
s!====+!<hr noshade="noshade" size="2" />!g;
}
if($parse > 0) {
s!$SitePattern!WikiLink($1,$2)!eg;
s!$LinkPattern!WikiLink($1,$1)!eg;
s!$UriPattern!<a href="$1">$2</a>!g;
s!$UrlPattern!<a href="$1">$1</a>!g;
s!$SendPattern!<a href="mailto:$1">$2</a>!g;
s!$MailPattern!<a href="mailto:$1">$1</a>!g;
}
return $_;
}
sub WikiLink {
my ($page,$name) = @_;
if($page =~ /cpan:~(.*)/) {
$page =~ s!cpan:~!!;
$name =~ s!cpan:~!!;
return qq!<a href="http://search.cpan.org/~$page">$name</a>!;
} elsif($page =~ /cpan:(.*)/) {
$page =~ s!cpan:!!;
$name =~ s!cpan:!!;
return qq!<a href="http://search.cpan.org/dist/$page">$name</a>!;
} elsif($page =~ /perldoc:(.*)/) {
$page =~ s!perldoc:!!;
$name =~ s!perldoc:!!;
return qq!<a href="http://perldoc.perl.org?$page">$name</a>!;
} elsif($page =~ /user:(\d+|[\w ]+)/) {
$name = undef if($page eq $name);
return _mapuser($1,$name);
} elsif($page =~ /image:(\d+)/) {
return _mapimage(id => $1);
} elsif($page =~ /image:(.*)/) {
return _mapimage(name => $1);
} elsif($page =~ /media:(\d+)/) {
return _mapmedia(id => $1);
} elsif($page =~ /media:(.*)/) {
return _mapmedia(name => $1);
}
$wiki_links{$page} ||= do {
my @rows = $dbi->GetQuery('hash','CheckWikiPage',$page);
@rows ? 1 : 0;
};
if($wiki_links{$page}) {
return qq!<a href="/wiki/$page">$name</a>!
}
return qq!<a href="/wiki/$page">$name</a>?!
}
sub WikiHeading {
my ($pre, $depth, $text) = @_;
$depth = length($depth) - 1;
$depth = 6 if ($depth > 6);
return $pre . "<h$depth>$text</h$depth>\n";
}
# -------------------------------------
# Private Methods
sub _mapuser {
my $id = shift;
my $nm = $id;
if($id =~ /^\d+$/) {
$nm = UserName($id);
} else {
$id = UserID($id);
}
return qq!<a href="/user/$id" title="User:$nm">$nm</a>!;
}
sub _mapimage {
my %hash = @_;
my @rows;
if($hash{id}) {
@rows = $dbi->GetQuery('hash','GetImageByID',$hash{id});
} else {
@rows = $dbi->GetQuery('hash','GetImageByName',$hash{id});
}
return unless(@rows);
return qq!<img src="$tvars{webpath}/images/$rows[0]->{link}" alt="$rows[0]->{tag}" />!;
}
sub _mapmedia {
my %hash = @_;
my @rows;
if($hash{id}) {
@rows = $dbi->GetQuery('hash','GetImageByID',$hash{id});
} else {
@rows = $dbi->GetQuery('hash','GetImageByName',$hash{id});
}
return unless(@rows);
return qq!<a href="$tvars{webpath}/images/$rows[0]->{link}" title="$rows[0]->{tag}">$rows[0]->{tag}</a>!;
}
1;
__END__
=back
=head1 SEE ALSO
L<Labyrinth>
=head1 AUTHOR
Barbie, <barbie@missbarbell.co.uk> for
Miss Barbell Productions, L<http://www.missbarbell.co.uk/>
=head1 COPYRIGHT & LICENSE
Copyright (C) 2008-2013 Barbie for Miss Barbell Productions
All Rights Reserved.
This module is free software; you can redistribute it and/or
modify it under the Artistic License 2.0.
=cut