File Coverage

blib/lib/Text/WikiFormat.pm

Criterion	Covered	Total	%
statement	176	176	100.0
branch	57	60	95.0
condition	32	38	84.2
subroutine	29	29	100.0
pod	2	15	13.3
total	296	318	93.0

package Text::WikiFormat;

use strict;

use URI;
use Carp ();
use URI::Escape;
use Text::WikiFormat::Blocks;
use Scalar::Util qw( blessed reftype );

use vars qw( $VERSION %tags $indent );
$VERSION = '0.81';
$indent  = qr/^(?:\t+|\s{4,})/;
%tags    = (
	indent		=> qr/^(?:\t+|\s{4,})/,
	newline		=> '',
	link		=> \&make_html_link,
	strong		=> sub { "$_[0]" },
	emphasized	=> sub { "$_[0]" },
	strong_tag  => qr/'''(.+?)'''/,
	emphasized_tag => qr/''(.+?)''/,

	code		=> [ '', "\n", '', "\n" ],
	line		=> [ '', "\n", '',  "\n" ],
	paragraph	=> [ '', "\n", '', "\n", 1 ],
	unordered	=> [ "\n", "\n", '', "\n" ],
	ordered		=> [ "\n", "\n",
		sub { qq||, $_[0], "\n" } ],
	header      => [ '', "\n", sub {
		my $level = length $_[2];
		return "", format_line($_[3], @_[-2, -1]), "\n" }
	],

	blocks		=> {
		ordered		=> qr/^([\dA-Za-z]+)\.\s*/,
		unordered	=> qr/^\*\s*/,
		code		=> qr/^(?:\t+|\s{4,})  /,
		header      => qr/^(=+) (.+) \1/,
		paragraph   => qr/^/,
		line        => qr/^-{4,}/,
	},

	indented    => { map { $_ => 1 } qw( ordered unordered )},
	nests       => { map { $_ => 1 } qw( ordered unordered ) },

	blockorder               =>
		[qw( header line ordered unordered code paragraph )],
	extended_link_delimiters => [qw( [ ] )],

	schemas => [ qw( http https ftp mailto gopher ) ],
);

sub process_args
{
	my $self = shift;

	return as => 'wikiformat' unless @_;
	return as => shift        if     @_ == 1;
	return as => 'wikiformat',       @_;
}

sub default_opts
{
	my ($class, $args) = @_;

	return
		implicit_links => 1,
		map { $_ => delete $args->{ $_ } }
		    qw( prefix extended implicit_links absolute_links );
}

sub merge_hash
{
	my ($from, $to) = @_;

	while (my ($key, $value) = each %$from)
	{
		if ((reftype( $value ) || '' ) eq 'HASH' )
		{
			$to->{$key} = {} unless defined $to->{$key};
			merge_hash( $value, $to->{$key} );
			next;
		}

		$to->{$key} = $value;
	}

	return $to;
}

sub import
{
	my $class   = shift;
	return unless @_;

	my %args    = $class->process_args( @_ );
	my %defopts = $class->default_opts( \%args );

	my $caller  = caller();
	my $name    = delete $args{as};

	no strict 'refs';
	*{ $caller . "::$name" } = sub
	{
		my ($text, $tags, $opts) = @_;

		$tags ||= {};
		$opts ||= {};

		my %tags = %args;
		merge_hash( $tags, \%tags );
		my %opts = %defopts;
		merge_hash( $opts, \%opts );

		Text::WikiFormat::format( $text, \%tags, \%opts);
	}
}

sub format
{
	my ($text, $newtags, $opts) = @_;

	$opts    ||=
	{
		prefix => '', extended => 0, implicit_links => 1, absolute_links => 0,
		nofollow_extended => 0
	};

	my %tags   = %tags;

	merge_hash( $newtags, \%tags )
		if defined $newtags and ( reftype( $newtags ) || '' ) eq 'HASH';
	check_blocks( \%tags )
		if exists $newtags->{blockorder} or exists $newtags->{blocks};

	my @blocks =  find_blocks( $text,     \%tags, $opts );
	@blocks    = merge_blocks( \@blocks                 );
	@blocks    =  nest_blocks( \@blocks                 );
	return     process_blocks( \@blocks,  \%tags, $opts );
}

sub check_blocks
{
	my $tags   = shift;
	my %blocks = %{ $tags->{blocks} };
	delete @blocks{ @{ $tags->{blockorder} } };

	if (keys %blocks)
	{
		require Carp;
		Carp::carp(
			"No order specified for blocks '" . join(', ', keys %blocks )
			. "'\n"
		)
	}
}

sub find_blocks
{
	my ($text, $tags, $opts) = @_;

	my @blocks;
	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) = @_;
	return new_block( 'end', level => 0 ) unless $text;

	for my $block (@{ $tags->{blockorder} })
	{
		my ($line, $level, $indentation)  = ( $text, 0, '' );

		if ($tags->{indented}{$block})
		{
			($level, $line, $indentation) = get_indentation( $tags, $line );
			next unless $level;
		}

		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,
		);
	}
}

# merge_blocks() and nest_blocks()
BEGIN
{
	for my $op (qw( merge nest ))
	{
		no strict 'refs';
		*{ $op . '_blocks' } = sub
		{
			my $blocks    = shift;
			return unless @$blocks;

			my @processed = shift @$blocks;

			for my $block (@$blocks)
			{
				push @processed, $processed[-1]->$op( $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 ($start, $end, $start_line, $end_line, $between)
		= @{ $tags->{ $block->type() } };

	my @text;

	for my $line ( $block->formatted_text() )
	{
		if (blessed( $line ))
		{
			my $prev_end = pop @text || ();
			push @text, process_block( $line, $tags, $opts ), $prev_end;
			next;
		}

		if ((reftype( $start_line ) || '' ) eq 'CODE' )
		{
			(my $start_line, $line, $end_line) =
				$start_line->(
					$line, $block->level(), $block->shift_args(), $tags, $opts
				);
			push @text, $start_line;
		}
		else
		{
			push @text, $start_line;
		}
		push @text, $line, $end_line;
	}

	pop @text if $between;
	return join('', $start, @text, $end);
}

sub get_indentation
{
	my ($tags, $text) = @_;

	return 0, $text unless $text =~ s/($tags->{indent})//;
	return( length( $1 ) + 1, $text, $1 );
}

sub format_line
{
	my ($text, $tags, $opts) = @_;
	$opts ||= {};

	$text =~ s!$tags->{strong_tag}!$tags->{strong}->($1, $opts)!eg;
	$text =~ s!$tags->{emphasized_tag}!$tags->{emphasized}->($1, $opts)!eg;

	$text = find_extended_links( $text, $tags, $opts ) if $opts->{extended};

	$text =~ s|(?=])\b((?:[A-Z][a-z0-9]\w*){2,})|
			  $tags->{link}->($1, $opts)|egx
			if !defined $opts->{implicit_links} or $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_extended_links
{
	my ($text, $tags, $opts) = @_;

    my $schemas = join('|', @{$tags->{schemas}});
    $text =~ s!(^|\s+)(($schemas):\S+)!$1 . $tags->{link}->($2, $opts)!egi
	    if $opts->{absolute_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 ) || '';
		$text                      = $before . $extended . $after;
	};

	return $text;
}

sub make_html_link
{
	my ($link, $opts)        = @_;
	$opts                  ||= {};

	($link, my $title)       = find_link_title( $link, $opts );
	($link, my $is_relative) = escape_link( $link, $opts );

	my $prefix               = ( defined $opts->{prefix} && $is_relative )
		? $opts->{prefix} : '';

	my $nofollow             = (!$is_relative && $opts->{nofollow_extended})
		? ' rel="nofollow"' : '';

	return qq|$title|;
}

sub escape_link
{
	my ($link, $opts) = @_;

	my $u = URI->new( $link );
	return $link if $u->scheme();

	# it's a relative link
	return( uri_escape( $link ), 1 );
}

sub find_link_title
{
	my ($link, $opts)  = @_;
	my $title;

	($link, $title)    = split(/\|/, $link, 2) if $opts->{extended};
	$title             = $link unless $title;

	return $link, $title;
}

'shamelessly adapted from the Jellybean project';

__END__