File Coverage

blib/lib/Labyrinth/Plugin/Wiki/Text.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

package Labyrinth::Plugin::Wiki::Text;

use warnings;
use strict;

use vars qw($VERSION);
$VERSION = '1.06';

=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  ...  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!^(.*?)!!) {
        $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/^(\*+)//) {
            $code = "ul";
            $depth = length $1;
        } elsif (s/^(\#+)//) {
            $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 .= '\n";
        }
        if ($depth > 0) {
#            $depth = $IndentLimit    if ($depth > $IndentLimit);
            if (@stack) {    # Non-empty stack
                $oldcode = pop(@stack);
                if ($oldcode ne $code) {
                    $html .= "<$code>\n";
                }
                push(@stack, $code);
            }
            while (@stack < $depth) {
                push(@stack, $code);
                $html .= "<$code>\n";
            }
        }

        if($code eq 'pre') {
            s!^\s*$!\n!;  # Blank lines become new lines
        } else {
            s!^\s*$!!;     # Blank lines become new paragraphs
        }
        $html .= CommonMarkup($_, $parse);
    }
    while (@stack > 0) {             # Clear stack
        $html .= '\n";
    }

    $html = process_html($html,0,1);

#    $html =~ s!(.*?)\s*<(ul|ol|h[1-6]|pre|p)>!$1\n<$2>!gs;    # close 's.
#    $html =~ s!(.*?)\s*$!$1!gs;               # close final .
#    $html =~ s!\s*\s*!!gs;                  # remove extra close paragraphs
#    $html =~ s!\s*!!gs;                          # remove black paragraphs
#    $html =~ s/(\s|)*\s*/\n/gs;                # multiple blank lines fold into one.
#    $html =~ s/\s*\s*<(ul|ol|h[1-6]|pre)/\n<$1/gs;   # remove unnecessary 's.
#    $html =~ s!([^>\s]+)\s*!$1\n!gs;          # close paragraphs.
#    $html =~ s!\s*\s*\n

    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\>!$1!ig;
    s!\<code\>((.|\n)*?)\<\/code\>!$1!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/!!(.*?)!!/$1<\/code>/g; #'
    s/('*)'''(.*?)'''/$1$2<\/strong>/g; #'
    s/''(.*?)''/$1<\/em>/g;
    s/(^|\n)\s*(\=+)\s+([^\n]+)\s+\=+/WikiHeading($1, $2, $3)/geo;

    s!\<br\>!!g;
    s!----+!!g;
    s!====+!!g;
  }

  if($parse > 0) {
    s!$SitePattern!WikiLink($1,$2)!eg;
    s!$LinkPattern!WikiLink($1,$1)!eg;

    s!$UriPattern!$2!g;
    s!$UrlPattern!$1!g;

    s!$SendPattern!$2!g;
    s!$MailPattern!$1!g;
  }

  return $_;
}

sub WikiLink {
    my ($page,$name) = @_;

    if($page =~ /cpan:~(.*)/) {
        $page =~ s!cpan:~!!;
        $name =~ s!cpan:~!!;
        return qq!$name!;
    } elsif($page =~ /cpan:(.*)/) {
        $page =~ s!cpan:!!;
        $name =~ s!cpan:!!;
        return qq!$name!;
    } elsif($page =~ /perldoc:(.*)/) {
        $page =~ s!perldoc:!!;
        $name =~ s!perldoc:!!;
        return qq!$name!;
    } 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!$name!
    }

    return qq!$name?!
}

sub WikiHeading {
  my ($pre, $depth, $text) = @_;

  $depth = length($depth) - 1;
  $depth = 6  if ($depth > 6);
  return $pre . "$text\n";
}

# -------------------------------------
# Private Methods

sub _mapuser {
    my $id = shift;
    my $nm = $id;

    if($id =~ /^\d+$/) {
        $nm = UserName($id);
    } else {
        $id = UserID($id);
    }

    return qq!$nm!;
}

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!!;
}

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!$rows[0]->{tag}!;
}

1;

__END__