File Coverage

blib/lib/Text/GooglewikiFormat.pm

Criterion	Covered	Total	%
statement	170	176	96.5
branch	45	52	86.5
condition	21	31	67.7
subroutine	26	26	100.0
pod	0	14	0.0
total	262	299	87.6

package Text::GooglewikiFormat;

use warnings;
use strict;
use URI;
use URI::Escape;
use Text::GooglewikiFormat::Blocks;
use Scalar::Util qw( blessed reftype );
use URI::Find;

use vars qw( $VERSION %tags $indent $code_delimiters);
$VERSION = '0.05';
$indent  = qr/^(?:\t+|\s{4,})/;
$code_delimiters = 0;
%tags    = (
	indent		=> qr/^(?:\t+|\s{1,})/,
	newline		=> '',

	strong		=> sub { " $_[0] " },
	italic      => sub { " $_[0] " },
	strike   	=> sub { qq~ $_[0] ~ },
	superscript => sub { "$_[0]" },
	subscript   => sub { "$_[0]" },
	inline      => sub { "$_[0]" },
	strong_tag  => qr/(^|\s+)\*(.+?)\*(\s+|$)/,
	italic_tag  => qr/(^|\s+)_(.+?)_(\s+|$)/,
	strike_tag  => qr/(^|\s+)\~\~(.+?)\~\~(\s+|$)/,
	superscript_tag => qr/\^(.+?)\^/,
	subscript_tag   => qr/\,\,(.+?)\,\,/,
	inline_tag  => qr/\`(.+?)\`/,

    header      => [ '', '', sub {
		my $level = length $_[2];
		return "", format_line($_[3], @_[-2, -1]), "" }
	],
	unordered   => ["", "", '', " "],
    ordered		=> ["", "", '', " "],

	code		=> [ '', "", sub {
	    my ($line, $level, $args, $tags, $opts) = @_;
	    $line =~ s/(^\{\{\{|\}\}\}$)//isg;
	    return (length($line)) ? $line . "\n" : '';
	} ],
	paragraph	=> [ '', "", '', "", 1 ],
	quote       => [ '', "", '', "\n"],
	table       => [ '', '', sub {
	    my ($line, $level, $args, $tags, $opts) = @_;
	    $line =~ s/(^\|\||\|\|$)//isg;
	    $line =~ s/\|\|/\<\/td\>\
	    $line = qq~
	    return $line,
	} ],


	blocks		=> {
	    header      => qr/^(=+)(.+)\1/,
		ordered		=> qr/^\#\s*/,
		unordered	=> qr/^\*\s*/,
	    quote       => qr/^ /,
		paragraph   => qr/^/,
		table       => qr/^\|\|/,
	},

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

	blockorder               =>
		[qw( header ordered unordered table quote paragraph code )],

	link		=> \&make_html_link,
	extended_link_delimiters => [qw( [ ] )],
	schemas => [ qw( http https ftp mailto gopher ) ],
);

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 format {
	my ($text, $newtags, $opts) = @_;

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

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

    # find URIs
    my $finder = URI::Find->new( sub {
        my($uri, $orig_uri) = @_;
        # If your link points to an image (that is, if it ends in .png, .gif, .jpg or .jpeg), it will get inserted as an image into the page:
        if ($uri =~ /\.(jpe?g|png|gif)$/) {
            return qq| |;
        } else {
            return qq|[$uri]|;
        }
    } );
    $finder->find(\$text);
    $text =~ s/\[\[(.+?)\]/\[$1/isg; # dirty hack

	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 {{{ }}}
    if ($text =~ /^\}\}\}$/) {
        $code_delimiters = 0;
        return new_block( 'end', level => 1 );
    } elsif ($code_delimiters or $text =~ /^\{\{\{$/) {
        $code_delimiters = 1;
        return new_block( 'code', level => 1, text => $text, opts => $opts, tags => $tags );
    }

	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;

	@text = grep { defined $_ } @text; # remove warnings
	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}->($2, $opts)!eg;
	$text =~ s!$tags->{italic_tag}!$tags->{italic}->($2, $opts)!eg;
	$text =~ s!$tags->{strike_tag}!$tags->{strike}->($2, $opts)!eg;
	$text =~ s!$tags->{superscript_tag}!$tags->{superscript}->($1, $opts)!eg;
	$text =~ s!$tags->{subscript_tag}!$tags->{subscript}->($1, $opts)!eg;
	$text =~ s!$tags->{inline_tag}!$tags->{inline}->($1, $opts)!eg;

	$text = find_extended_links( $text, $tags, $opts );

	$text =~ s|(?=])\b((?:[A-Z][a-z0-9]\w*){2,})|
			  $tags->{link}->($1, $opts)|egx;

	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;

	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} : '';

    unless ($is_relative) {
        return qq|$title|;
    } else {
    	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(/\s+/, $link, 2);
	$title             = $link unless $title;

	return $link, $title;
}

'shamelessly adapted from the Jellybean project, directly from Text::WikiFormat';

__END__