_append_processed_line $parser, $newtag, 'html';
return;
}
if ( @$tagstack && grep /^\Q$stacktop\E$/, qw{nowiki pre} ) {
# Ignore all markup within or tags.
_append_processed_line $parser, CGI::escapeHTML($orig), 'nowiki';
return;
}
if ( $type eq 'E' && $HTML::Tagset::isPhraseMarkup{$tagname} )
# If we ask for artificial end element events for self-closed elements,
# then we need to check $HTML::Tagset::emptyElement($tagname) here too.
{
# We didn't record phrase markup on the stack, so it's okay to just
# let it close.
_append_processed_line $parser, "";
return;
}
if ( $type eq 'E' ) {
# We got a non-phrase end tag that wasn't on the stack. Escape it.
_append_processed_line $parser, CGI::escapeHTML($orig);
return;
}
###
### $type must now eq 'S'.
###
# The browser doesn't need to see the tag.
if ( $tagname eq 'nowiki' ) {
push @$tagstack, $tagname
unless $isEmptyTag;
return;
}
# Strip disallowed attributes.
my $newtag = "<$tagname";
foreach ( @{ $tags->{allowed_attrs} } ) {
if ( defined $attr->{$_} ) {
$newtag .= " $_";
unless ( $attr->{$_} eq '__TEXT_MEDIAWIKIFORMAT_BOOL__' ) {
# CGI::escapeHTML escapes single quotes.
$attr->{$_} = CGI::escapeHTML $attr->{$_};
$newtag .= "='" . $attr->{$_} . "'";
}
}
}
$newtag .= " /" if $HTML::Tagset::emptyElement{$tagname} || $isEmptyTag;
$newtag .= ">";
# If this isn't a block level element, there's no need to track nesting.
if ( $HTML::Tagset::isPhraseMarkup{$tagname}
|| $HTML::Tagset::emptyElement{$tagname} )
{
_append_processed_line $parser, $newtag;
return;
}
# Some elements can close implicitly
if (@$tagstack) {
if ( $tagname eq $stacktop
&& $HTML::Tagset::optionalEndTag{$tagname} )
{
pop @$tagstack;
}
elsif ( !$HTML::Tagset::is_Possible_Strict_P_Content{$tagname} ) {
# Need to check more than the last item for paragraphs.
for ( my $i = $#{$tagstack}; $i >= 0; $i-- ) {
my $checking = $tagstack->[$i];
last if grep /^\Q$checking\E$/, @HTML::Tagset::p_closure_barriers;
if ( $checking eq 'p' ) {
# pop 'em all.
splice @$tagstack, $i;
last;
}
}
}
}
# Could verify here that and sub-elements only appear where
# they belong.
# Push the new tag onto the stack.
push @$tagstack, $tagname
unless $isEmptyTag;
_append_processed_line $parser, $newtag, $tagname eq 'pre' ? 'nowiki' : 'html';
return;
}
sub _html_comment {
my ( $parser, $text ) = @_;
_append_processed_line $parser, $text, 'nowiki';
}
sub _html_text {
my ( $parser, $dtext, $skipped_text, $is_cdata ) = @_;
my $tagstack = $parser->{tag_stack};
my ( $newtext, $newstate );
warnings::warnif("Got skipped_text: `$skipped_text'")
if $skipped_text;
if (@$tagstack) {
if ( grep /\Q$tagstack->[-1]\E/, qw{nowiki pre} ) {
$newstate = 'nowiki';
}
elsif ( $is_cdata && $HTML::Tagset::isCDATA_Parent{ $tagstack->[-1] } ) {
# If the user hadn't specifically allowed a tag which contains
# CDATA, then it won't be on the tag stack.
$newtext = $dtext;
}
}
unless ( defined $newtext ) {
$newtext = CGI::escapeHTML $dtext unless defined $newtext;
# CGI::escapeHTML escapes single quotes so the text may be included
# in attribute values, but we know we aren't processing an attribute
# value here.
$newtext =~ s/'/'/g;
}
_append_processed_line $parser, $newtext, $newstate;
}
sub _find_blocks_in_html {
my ( $text, $tags, $opts ) = @_;
my $parser = HTML::Parser->new(
start_h => [ \&_html_tag, 'self, "S", tagname, text, attr' ],
end_h => [ \&_html_tag, 'self, "E", tagname, text' ],
comment_h => [ \&_html_comment, 'self, text' ],
text_h => [ \&_html_text, 'self, dtext, skipped_text, is_cdata' ],
marked_sections => 1,
boolean_attribute_value => '__TEXT_MEDIAWIKIFORMAT_BOOL__',
);
$parser->{opts} = $opts;
$parser->{tags} = $tags;
$parser->{processed_lines} = [];
$parser->{tag_stack} = [];
my @blocks;
my @lines = split /\r?\n/, $text;
for ( my $i = 0; $i < @lines; $i++ ) {
$parser->parse( $lines[$i] );
$parser->parse("\n");
$parser->eof if $i == $#lines;
# @{$parser->{processed_lines}} may be empty when tags are
# still open.
while ( @{ $parser->{processed_lines} }
&& $parser->{processed_lines}->[0]->[2] )
{
my ( $type, $dtext )
= @{ shift @{ $parser->{processed_lines} } };
my $block;
if ($type) {
$block = _start_block( $dtext, $tags, $opts, $type );
}
else {
chomp $dtext;
$block = _start_block( $dtext, $tags, $opts );
}
push @blocks, $block if $block;
}
}
return @blocks;
}
sub _find_blocks {
my ( $text, $tags, $opts ) = @_;
my @blocks;
if ( $opts->{process_html} ) {
@blocks = _find_blocks_in_html $text, $tags, $opts;
}
else {
# The original behavior.
for my $line ( split /\r?\n/, $text ) {
my $block = _start_block( $line, $tags, $opts );
push @blocks, $block if $block;
}
}
return @blocks;
}
sub _start_block {
my ( $text, $tags, $opts, $type ) = @_;
return new_block( 'end', level => 0 ) unless $text;
return new_block(
$type,
level => 0,
opts => $opts,
text => $text,
tags => $tags,
) if $type;
for my $block ( @{ $tags->{blockorder} } ) {
my ( $line, $level, $indentation ) = ( $text, 0, '' );
( $level, $line, $indentation ) = _get_indentation( $tags, $line )
if $tags->{indented}{$block};
my $marker_removed = length( $line =~ s/$tags->{blocks}{$block}// );
next unless $marker_removed;
return new_block(
$block,
args => [ grep {defined} $1, $2, $3, $4, $5, $6, $7, $8, $9 ],
level => $level || 0,
opts => $opts,
text => $line,
tags => $tags,
);
}
}
sub _nest_blocks {
my $blocks = shift;
return unless @$blocks;
my @processed = shift @$blocks;
for my $block (@$blocks) {
push @processed, $processed[-1]->nest($block);
}
return @processed;
}
sub _process_blocks {
my ( $blocks, $tags, $opts ) = @_;
my @open;
for my $block (@$blocks) {
push @open, _process_block( $block, $tags, $opts )
unless $block->type() eq 'end';
}
return join '', @open;
}
sub _process_block {
my ( $block, $tags, $opts ) = @_;
my $type = $block->type();
my ( $start, $end, $start_line, $end_line, $between );
if ( $tags->{$type} ) {
( $start, $end, $start_line, $end_line, $between ) = @{ $tags->{$type} };
}
else {
( $start, $end, $start_line, $end_line ) = ( '', '', '', '' );
}
my @text = ();
for my $line (
grep ( /^\Q$type\E$/, @{ $tags->{unformatted_blocks} } )
? $block->text()
: $block->formatted_text()
)
{
if ( blessed $line) {
my $prev_end = pop @text || ();
push @text, _process_block( $line, $tags, $opts ), $prev_end;
next;
}
my @triplets;
if ( ( ref($start_line) || '' ) eq 'CODE' ) {
@triplets = $start_line->( $line, $block->level(), $block->shift_args(), $tags, $opts );
}
else {
@triplets = ( $start_line, $line, $end_line );
}
push @text, @triplets;
}
pop @text if $between;
return join '', $start, @text, $end;
}
sub _get_indentation {
my ( $tags, $text ) = @_;
return 1, $text unless $text =~ s/($tags->{indent})//;
return length($1) + 1, $text, $1;
}
=head2 format_line
$formatted = format_line ($raw, $tags, $opts);
This function is never exported. It formats the phrase elements of a single
line of text (emphasised, strong, and links).
This is only meant to be called from L and so
requires $tags and $opts to have all elements filled in. If you find a use for
it, please let me know and maybe I will have it default the missing elements as
C does.
=cut
sub format_line {
my ( $text, $tags, $opts ) = @_;
$text =~ s!$tags->{strong_tag}!$tags->{strong}->($1, $opts)!eg;
$text =~ s!$tags->{emphasized_tag}!$tags->{emphasized}->($1, $opts)!eg;
$text = _find_links( $text, $tags, $opts )
if $opts->{extended}
|| $opts->{absolute_links}
|| $opts->{implicit_links};
return $text;
}
sub _find_innermost_balanced_pair {
my ( $text, $open, $close ) = @_;
my $start_pos = rindex $text, $open;
return if $start_pos == -1;
my $end_pos = index $text, $close, $start_pos;
return if $end_pos == -1;
my $open_length = length $open;
my $close_length = length $close;
my $close_pos = $end_pos + $close_length;
my $enclosed_length = $close_pos - $start_pos;
my $enclosed_atom = substr $text, $start_pos, $enclosed_length;
return substr( $enclosed_atom, $open_length, 0 - $close_length ),
substr( $text, 0, $start_pos ),
substr( $text, $close_pos );
}
sub _find_links {
my ( $text, $tags, $opts ) = @_;
# Build Regexp
my @res;
if ( $opts->{absolute_links} ) {
# URI
my $s;
$tags->{_schema_regex} ||= _make_schema_regex @{ $tags->{schemas} };
$s = $tags->{_schema_regex};
push @res, qr/\b$s:[$uricCheat][$uric]*/;
}
if ( $opts->{implicit_links} ) {
# StudlyCaps
if ( $tags->{implicit_link_delimiters} ) {
push @res, qr/$tags->{implicit_link_delimiters}/;
}
else {
warnings::warnif("Ignoring implicit_links option since implicit_link_delimiters is empty");
}
}
if ( $opts->{extended} ) {
# [[Wiki Page]]
if ( !$tags->{extended_link_delimiters} ) {
warnings::warnif("Ignoring extended option since extended_link_delimiters is empty");
}
elsif ( ref $tags->{extended_link_delimiters} eq "ARRAY" ) {
# Backwards compatibility for extended links.
# Bypasses the regex substitution used by absolute and implicit
# links.
my ( $start, $end ) = @{ $tags->{extended_link_delimiters} };
while ( my @pieces = _find_innermost_balanced_pair( $text, $start, $end ) ) {
my ( $tag, $before, $after ) = map { defined $_ ? $_ : '' } @pieces;
my $extended = $tags->{link}->( $tag, $opts, $tags ) || '';
$text = $before . $extended . $after;
}
}
else {
push @res, qr/$tags->{extended_link_delimiters}/;
}
}
if (@res) {
my $re = join "|", @res;
$text =~ s/$re/$tags->{link}->($&, $opts, $tags)/ge;
}
return $text;
}
=head1 Wiki Format
Refer to L for
description of the default wiki format, as interpreted by this module. Any
discrepencies will be considered bugs in this module, with a few exceptions.
=head2 Unimplemented Wiki Markup
=over 4
=item Templates, Magic Words, and Wanted Links
Templates, magic words, and the colorization of wanted links all require a back
end data store that can be consulted on the existance and content of named
pages. C has deliberately been constructed such that it
operates independantly from such a back end. For an interface to
C which implements these features, see
L.
=item Tables
This is on the TODO list.
=back
=head1 EXPORT
If you'd like to make your life more convenient, you can optionally import a
subroutine that already has default tags and options set up. This is
especially handy if you use a prefix:
use Text::MediawikiFormat prefix => 'http://www.example.com/';
wikiformat ('some text');
Tags are interpreted as default members of the $tags hash normally passed to
C, except for the five options (see above) and the C key, who's
value is interpreted as an alternate name for the imported function.
To use the C flag to control the name by which your code calls the imported
function, for example,
use Text::MediawikiFormat as => 'formatTextWithWikiStyle';
formatTextWithWikiStyle ('some text');
You might choose a better name, though.
The calling semantics are effectively the same as those of the C
function. Any additional tags or options to the imported function will
override the defaults. This code:
use Text::MediawikiFormat as => 'wf', extended => 0;
wf ('some text', {}, {extended => 1});
enables extended links, after specifying that the default behavior should be
to disable them.
=head1 GORY DETAILS
=head2 Tags
There are two types of Wiki markup: phrase markup and blocks. Blocks include
lists, which are made up of lines and can also contain other lists.
=head3 Phrase Markup
The are currently three types of wiki phrase markup. These are the
strong and emphasized markup and links. Links may additionally be of three
subtypes, extended, implicit, or absolute.
You can change the regular expressions used to find strong and emphasized tags:
%tags = (
strong_tag => qr/\*([^*]+?)\*/,
emphasized_tag => qr|/([^/]+?)/|,
);
$wikitext = 'this is *strong*, /emphasized/, and */em+strong/*';
$htmltext = wikiformat ($wikitext, \%tags, {});
You can also change the regular expressions used to find links. The following
just sets them to their default states (but enables parsing of implicit links,
which is I the default):
my $html = wikiformat
(
$raw,
{implicit_link_delimiters => qr!\b(?:[A-Z][a-z0-9]\w*){2,}!,
extended_link_delimiters => qr!\[(?:\[[^][]*\]|[^][]*)\]!,
},
{implicit_links => 1}
);
In addition, you may set the function references that format strong and
emphasized text and links. The strong and emphasized functions receive only
the text to be formatted as an argument and are expected to return the
formatted text. The link formatter also recieves references to the C<$tags>
and C<$opts> arrays. For example, the following sets the strong and
emphasized formatters to their default state while replacing the link formatter
with one which strips href information and returns only the title text:
my $html = wikiformat
(
$raw,
{strong => sub {"$_[0]"},
emphasized => sub {"$_[0]"},
link => sub
{
my ($tag, $opts, $tags) = @_;
if ($tag =~ s/^\[\[([^][]+)\]\]$/$1/)
{
my ($page, $title) = split qr/\|/, $tag, 2;
return $title if $title;
return $page;
}
elsif ($tag =~ s/^\[([^][]+)\]$/$1/)
{
my ($href, $title) = split qr/ /, $tag, 2;
return $title if $title;
return $href;
}
else
{
return $tag;
}
},
},
);
=head3 Blocks
The default block types are C, C, C, C,
C, C, C, and C.
Block entries in the tag hashes must contain array references. The first two
items are the tags used at the start and end of the block. The third and
fourth contain the tags used at the start and end of each line. Where there
needs to be more processing of individual lines, use a subref as the third
item. This is how the module processes ordered lines in HTML lists and
headers:
my $html = wikiformat
(
$raw,
{ordered => ['', "
\n", '', "\n"],
header => ['', "\n", \&_make_header],
},
);
The first argument to these subrefs is the post-processed text of the line
itself. (Processing removes the indentation and tokens used to mark this as a
list and checks the rest of the line for other line formattings.) The second
argument is the indentation level (see below). The subsequent arguments are
captured variables in the regular expression used to find this list type. The
regexp for headers is:
$html = wikiformat
(
$raw,
{blocks => {header => qr/^(=+)\s*(.+?)\s*\1$/}}
);
The module processes indentation first, if applicable, and stores the
indentation level (the length of the indentation removed).
Lists automatically start and end as necessary.
Because regular expressions could conceivably match more than one line, block
level markup is processed in a specific order. The C tag governs
this order. It contains a reference to an array of the names of the
appropriate blocks to process. If you add a block type, be sure to add an
entry for it in C:
my $html = wikiformat
(
$raw,
{invisible => ['', '', '', ''],
blocks => {invisible => qr!^--(.*?)--$!},
blockorder => [qw(code header line ordered
unordered definition invisible
paragraph_break paragraph)]
},
},
);
=head3 Finding blocks
As has already been mentioned in passing, C uses regular
expressions to find blocks. These are in the C<%tags> hash under the C
key. For example, to change the regular expression to find code block items,
use:
my $html = wikiformat ($raw, {blocks => {code => qr/^:\s+/}});
This will require a leading colon to mark code lines (note that as writted
here, this would interfere with the default processing of definition lists).
=head3 Finding Blocks in the Correct Order
As intrepid bug reporter Tom Hukins pointed out in CPAN RT bug #671, the order
in which C searches for blocks varies by platform and
version of Perl. Because some block-finding regular expressions are more
specific than others, what you intend to be one type of block may turn into a
different list type.
If you're adding new block types, be aware of this. The C entry in
C<%tags> exists to force C to apply its regexes from
most specific to least specific. It contains an array reference. By default,
it looks for ordered lists first, unordered lists second, and code references
at the end.
=head1 SEE ALSO
L
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Text::MediawikiFormat
You can also look for information at:
=over 4
=item * AnnoCPAN: Annotated CPAN documentation
L
=item * CPAN Ratings
L
=item * RT: CPAN's request tracker
L
=item * Search CPAN
L
=back
=head1 AUTHOR
Derek Price C is the author.
=head1 ACKNOWLEDGEMENTS
This module is derived from L, written by chromatic.
chromatic's original credits are below:
chromatic, C, with much input from the Jellybean team
(including Jonathan Paulett). Kate L Pugh has also provided several patches,
many failing tests, and is usually the driving force behind new features and
releases. If you think this module is worth buying me a beer, she deserves at
least half of it.
Alex Vandiver added a nice patch and tests for extended links.
Tony Bowden, Tom Hukins, and Andy H. all suggested useful features that are now
implemented.
Sam Vilain, Chris Winters, Paul Schmidt, and Art Henry have all found and
reported silly bugs.
Blame me for the implementation.
=head1 BUGS
The link checker in C may fail to detect existing links that do
not follow HTML, XML, or SGML style. They may die with some SGML styles too.
I.
=head1 TODO
=over 4
=item * Optimize C to work on a list of lines
=back
=head1 COPYRIGHT & LICENSE
Copyright (c) 2006-2008 Derek R. Price, all rights reserved.
Copyright (c) 2002 - 2006, chromatic, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of Text::MediaiwkiFormat
Text-MediawikiFormat-1.04/lib/Text/MediawikiFormat/Block.pm 000644 000765 000024 00000005250 12437046737 024046 0 ustar 00gabor staff 000000 000000 package Text::MediawikiFormat::Block;
use strict;
use warnings::register;
use Scalar::Util qw( blessed reftype );
our $VERSION = '1.04';
sub new {
my ( $class, %args ) = @_;
$args{text} = $class->arg_to_ref( delete $args{text} || '' );
$args{args} = [ $class->arg_to_ref( delete $args{args} || [] ) ];
bless \%args, $class;
}
sub arg_to_ref {
my ( $class, $value ) = @_;
return $value if ( reftype($value) || '' ) eq 'ARRAY';
return [$value];
}
sub shift_args {
my $self = shift;
my $args = shift @{ $self->{args} };
return wantarray ? @$args : $args;
}
sub all_args {
my $args = $_[0]{args};
return wantarray ? @$args : $args;
}
sub text {
my $text = $_[0]{text};
return wantarray ? @$text : $text;
}
sub add_text {
my $self = shift;
push @{ $self->{text} }, @_;
}
sub formatted_text {
my $self = shift;
return map { blessed($_) ? $_ : $self->formatter($_) } $self->text();
}
sub formatter {
my ( $self, $line ) = @_;
Text::MediawikiFormat::format_line( $line, $self->tags(), $self->opts() );
}
sub add_args {
my $self = shift;
push @{ $self->{args} }, @_;
}
{
no strict 'refs';
for my $attribute (qw( level opts tags type )) {
*{$attribute} = sub { $_[0]{$attribute} };
}
}
sub merge {
my ( $self, $next_block ) = @_;
return $next_block unless $self->type() eq $next_block->type();
return $next_block unless $self->level() == $next_block->level();
$self->add_text( $next_block->text() );
$self->add_args( $next_block->all_args() );
return;
}
sub nests {
my ( $self, $maynest ) = @_;
my $tags = $self->{tags};
return
exists $tags->{nests}{ $self->type() }
&& exists $tags->{nests}{ $maynest->type() }
&& $self->level()
< $maynest->level()
# tags nest anywhere, regardless of level and parent
|| exists $tags->{nests_anywhere}{ $maynest->type() };
}
sub nest {
my ( $self, $next_block ) = @_;
return unless $next_block = $self->merge($next_block);
return $next_block unless $self->nests($next_block);
# if there's a nested block at the end, maybe it can nest too
my $last_item = ( $self->text() )[-1];
return $last_item->nest($next_block) if blessed($last_item);
$self->add_text($next_block);
return;
}
1;
__END__
=head1 NAME
Text::MediawikiFormat::Block - blocktype for Text::MediawikiFormat
=head1 SYNOPSIS
None. Use L as the public interface, unless you want to
create your own block type. See also L.
=head1 AUTHOR
chromatic, C<< chromatic at wgz dot org >>
=head1 BUGS
No known bugs.
=head1 COPYRIGHT
Copyright (c) 2006, chromatic. Some rights reserved.
This module is free software; you can use, redistribute, and modify it under
the same terms as Perl 5.8.x.
Text-MediawikiFormat-1.04/lib/Text/MediawikiFormat/Blocks.pm 000644 000765 000024 00000006320 12437046746 024230 0 ustar 00gabor staff 000000 000000 package Text::MediawikiFormat::Blocks;
use strict;
use warnings::register;
use Text::MediawikiFormat::Block;
our $VERSION = '1.04';
sub import {
my $caller = caller();
no strict 'refs';
*{ $caller . '::new_block' } = sub {
my $type = shift;
my $class = "Text::MediawikiFormat::Block::$type";
*{ $class . '::ISA' } = ['Text::MediawikiFormat::Block']
unless $class->can('new');
return $class->new( type => $type, @_ );
};
}
1;
__END__
=head1 NAME
Text::MediawikiFormat::Blocks - blocktypes for Text::MediawikiFormat
=head1 SYNOPSIS
None. Use L as the public interface, unless you want to
create your own block type.
=head1 DESCRIPTION
This module merely creates subclasses of Text::MediawikiFormat::Block, which is
the interesting code. A block is a collection of related lines, such as a code
block (text to display verbatim in a monospaced font), a header, an unordered
list, an ordered list, and a paragraph (text to display in a proportional
font).
Every block extends C.
=head1 METHODS
The following methods exist:
=over 4
=item * C
Creates and returns a new block. The valid arguments are:
=over 4
=item * C
The text of the line found in the block.
=item * C
The arguments captured by the block-identifying regular expression.
=item * C
The level of indentation for the block (usually only useful for list blocks).
=item * C
The tags in effect for the current type of wiki formatting.
=item * C
The options in effect for the current type of wiki formatting.
=back
Use the accessors of the same names to retrieve the values of the attributes.
=item * C
Adds a list of lines of text to the current text for the block. This is very
useful when you encounter a block and want to merge it with the previous block
of the same type
=item * C
Adds further arguments to the block; useful when merging blocks.
=item * C
Returns text formatted appropriately for this block. Blocks don't have to have
formatters, but they may.
=item * C
Formats the C<$line> using C. You can add
your own formatter here; this is worth overriding.
=item * C
Merges the current block with C<$next_block> (the next block encountered) if
they're of the same type and are at the same level. This adds the text and
args of C<$next_block> to the current block. It's your responsibility to
remove C<$next_block> from whatever your code iterates over.
=item * C
Returns true if this block should nest (as in lists and unordered lists) for
the active wiki formatting.
=item * C
Nests C<$next_block> under this block if the both nest and if C<$next_block>
has a level greater than the current block. This actually adds C<$next_block>
as a text item within the current block. Beware.
=back
=head1 AUTHOR
chromatic, C<< chromatic at wgz dot org >>
=head1 BUGS
No known bugs.
=head1 COPYRIGHT
Copyright (c) 2006, chromatic. Some rights reserved.
This module is free software; you can use, redistribute, and modify it under
the same terms as Perl 5.8.x.