File Coverage

blib/lib/Text/Tiki.pm

Criterion	Covered	Total	%
statement	6	378	1.5
branch	0	138	0.0
condition	0	58	0.0
subroutine	2	61	3.2
pod	14	59	23.7
total	22	694	3.1

#
# Copyright 2003-4 Timothy Appnel.
# This code is released under the Artistic License.
#

package Text::Tiki;

use strict;

use vars qw( $VERSION );

$VERSION = 0.73;

# Explaination from HTML::FromText docs.
# This list of protocols is taken from RFC 1630: "Universal Resource
# Identifiers in WWW".  The protocol "file" is omitted because
# experience suggests that it results in many false positives; "https
# postdates RFC 1630.  The protocol "mailto" is handled separately, by
# the email address matching code.
my $protocol = join '|', qw(afs cid ftp gopher http https mid news nntp prospero telnet wais);

my %Map = ( '&' => '&', '"' => '"', '<' => '<', '>' => '>', "'" => ''' );
my $RE = join '|', keys %Map;

my $punc = '[.?!,:;\]\)\}]';
my $inline_start_boundry='[\s\t\[\(\{]'; # this sets off the search for a handler
my $term= qr/(?=$punc*?(\s|$))/; # checks that the following space to be sure the character isn't something inline
my $not_in_markup='(?:[^<>]*|<[^<>]*>)*?';
my $macro= qr/%%.*?%%/;

# __LT__ & __GT__ is the unfortunate side effect of not confusing the parser during processing.
my %cell_alignments = ( '__LT__' => 'left', '^' => 'center', '__GT__' => 'right' );
my $cell_alignment = '\\'.join '|\\', keys %cell_alignments;

my %block_handlers = (
				'_p' => \&hdlr_paragraph,
				'>' => \&hdlr_blockquote,
				'_pre' => \&hdlr_pre,
				'%' => \&hdlr_code_block,
				'-' => \&hdlr_hr,
				'_h1' => \&hdlr_h1,
				'_h2' => \&hdlr_h2,
				'_h3' => \&hdlr_h3,
				'_h4' => \&hdlr_h4,
				'_h5' => \&hdlr_h5,
				'_h6' => \&hdlr_h6,
				'*' => \&hdlr_ul,
				'#' => \&hdlr_ol,
				'_dl' => \&hdlr_dl,
				'|' => \&hdlr_table,
				'_macro' => \&hdlr_macro_block # for default block handler
				);

my %inline_handlers = (
				'*' => \&hdlr_strong,
				'/' => \&hdlr_emp,
				'+' => \&hdlr_insert,
				'-' => \&hdlr_delete,
				'~' => \&hdlr_subscript,
				'^' => \&hdlr_superscript,
				'"' => \&hdlr_quote,
				'%' => \&hdlr_code_inline,
				'@' => \&hdlr_cite,
				'[' => \&hdlr_hyperlink,
				'{' => \&hdlr_image,
				);

#--- external methods

sub new {
	my $class = shift;
	my $tiki = bless {}, $class;
	$tiki->init(@_);
	$tiki->clear_handlers(@_);
	return $tiki;
}

sub init {
	my $tiki = shift;
	$tiki->{__heading_names}={};
	$tiki->{__block_format_depth}=0;
	$tiki->{__inline_format_depth}=0;
	$tiki->{__macro_processing}=0;
	$tiki->{__wiki_implicit_links}=0;
	$tiki->{__wiki_prefix}='';
	$tiki->{__interwiki_links}=0;
	$tiki->{__interwiki_table}={ };
	$tiki->{__typographic_processing}=1;
	# should we store the original?
	# should we store the finished product?
}

sub format {
	my $tiki = shift;
	my $content = shift;
	unless ( ref($content) eq "ARRAY") {
		$content=~s/\r//g;
		my @lines = split(/\n/, $content);
		$content = \@lines;
	}
	return $tiki->block_format($content);
}

sub format_line {
	my $tiki = shift;
	my $line = shift;
	$tiki->inline_format(\$line);
	return $line
}

sub stash {
    my $tiki = shift;
    my $key = shift;
    $tiki->{__stash}->{$key} = shift if @_;
    return $tiki->{__stash}->{$key};
}

sub clear_handlers {
	$_[0]->{__wiki_links_handler} = \&wiki_link_default_processor;
	$_[0]->{__interwiki_links_handler} = \&interwiki_link_default_processor;
	$_[0]->{__macro_handlers} = undef;
}

#--- internal "workhorse" methods

sub block_format {
	my $tiki = shift;
	my $content=shift;
	my $index=0;
	my $buffer;
	my $out;
	my @pre_tail=();
	return '' unless (  @{ $content } );
	$tiki->{__block_format_depth}++;
	foreach my $line (@{ $content }) {
		$line =~s/^[\s\t]*$//; # cleans out false negatives linebreaks.
		unless ( length($line) ) {
			next unless( defined( $buffer->[$index]->{type} ) );
			if ( $buffer->[$index]->{type}!~/(_pre|%)/ ) {
				if ( @{ $buffer->[$index]->{buffer} } ) {
					$index++; $buffer->[$index]->{buffer} = ();
					next;
				}
			} else { push(@pre_tail,''); next; }
		} else {
			my $symbol=substr($line,0,1);
			if ($symbol=~/^[\s\t]/) {
				$symbol='_pre';
				push(@{ $buffer->[$index]->{buffer} },@pre_tail);
				@pre_tail=();
			} else {
				if ( @pre_tail ) { $index++; $buffer->[$index]->{buffer} = (); @pre_tail=(); }
				if ( $symbol eq '!'
						&& substr($line,1,2)=~/^[1-6]?[\s\t]/ ) {
					$line=~s/^!([1-6]?)[\s\t]//;
					$symbol = '_h'. ($1?$1:1);
				} elsif ($symbol eq '-') {
					if ($line=~/^----/) { $line=''; }
					else { $symbol = '_p'; }
				} elsif ($symbol eq '|') {
					# avoids further processing for now
				} elsif ($symbol=~/[:;]/) {
					$symbol = '_dl';
					# we don't strip the symbol here so the dl handler knows what is a
					# and what is a .
				} elsif ($tiki->{__macro_processing} && $symbol eq '%'  && $line=~/^$macro[\s\t]*$/) { # should use more precise regex that only accepts if alone on line.
					$symbol = '_macro';
				} elsif ( defined( $block_handlers{$symbol} )
						&&  ( ( $symbol=~/[#*]/ && substr($line,1,1)=~/[#*\s\t]/ ) || # Handles nested lists shortcut
						length($line) == 1 || # blank line in a block
						substr($line,1,1)=~/^[$symbol\s\t]/ ) ) {
					$line=~s/^[$symbol][\s\t]?//;
				} else { $symbol = '_p'; }
			}
			$buffer->[$index]->{type} = $symbol unless ( defined ( $buffer->[$index]->{type} ) );
		}
		# keeps encoder from getting confused during processing.
		$line=~s//__GT__/g;
		push(@{ $buffer->[$index]->{buffer} },$line);
		if ($buffer->[$index]->{type} eq '_macro') { $index++; $buffer->[$index]->{buffer} = (); }
	}
	pop( @{ $buffer } ) and $index-- unless ( $buffer->[-1]->{type} );
	foreach my $block ( @{ $buffer } ) {
		$out .= $block_handlers{ $block->{type} }->( $tiki, $block->{buffer} );
	}
	if ( ! ($tiki->{__block_format_depth}-1) && $tiki->{__macro_processing} ) {
		$out=~s/($macro)[\s\t]*/$tiki->hdlr_macro_block_postprocess($1)/meg; # should only work at start of the line
	}
	$tiki->{__block_format_depth}--;
	return $out?$out:'';
}

sub inline_format {
	my $tiki = shift;
	my $in = shift;
	my $out='';
	$tiki->{__inline_format_depth}++;
	while (defined($$in) && length($$in) > 2) {
		my $symbol = substr($$in,0,1);
		if ( $tiki->{__inline_format_depth}==1 && $symbol eq '%' && $tiki->{__macro_processing} ) {
			$$in=~s/^($macro)/$tiki->hdlr_macro_inline($1)/e;
			#macro was passed through.
			if ($$in=~s/^($macro)// && $1) {
				$out .= $1; next;
			}
			$symbol = substr($$in,0,1);
		}
		if ( defined( $inline_handlers{$symbol} ) &&
			(! length($out) || substr($out, length($out)-1 )=~/$inline_start_boundry/ ) ) {
			my ($start_tag,$enclosure,$end_tag) = $inline_handlers{ $symbol }->( $tiki, $in );
			if ( defined( $start_tag ) ) {
				$out .= $start_tag . $tiki->inline_format(\$enclosure) . $end_tag;
				next;
			}
		}
		$$in=~s/(.)//; $out.=$1;
	}
	$out .= defined($$in)?$$in:'';
	unless ( $tiki->{__inline_format_depth}-1 ) {
		$tiki->hdlr_autolink(\$out);
		$tiki->hdlr_wiki_link(\$out) if ( $tiki->{__wiki_implicit_links} );
		$tiki->hdlr_interwiki_link(\$out) if ( $tiki->{__interwiki_links} );
		$tiki->hdlr_acronym(\$out);
		encoding_processor(\$out, { typographic_processing => $tiki->{__typographic_processing} } );
		if ( $tiki->{__macro_processing} ) {
			$out=~s/($macro)/$tiki->hdlr_macro_inline_literal($1)/eg;
		}
	}
	$tiki->{__inline_format_depth}--;
	return $out;
}

#-- wiki handling routines.

sub wiki_implicit_links { $_[0]->{__wiki_implicit_links}=$_[1]; }
sub wiki_prefix { $_[0]->{__wiki_prefix}=$_[1]; }
sub interwiki_links { $_[0]->{__interwiki_links}=$_[1]; }
sub interwiki_table { $_[0]->{__interwiki_table}=$_[1]; }

sub wiki_links_handler { $_[0]->{__wiki_links_handler}=$_[1]; }
sub interwiki_links_handler { $_[0]->{__interwiki_links_handler}=$_[1]; }

sub hdlr_wiki_link { # regex borrowed from Text::WikiFormat
	my $tiki = shift;
	my $in = shift;
	$tiki->{__wiki_links_handler} ||= \&wiki_link_default_processor;
	$$in =~ s|(?=])\b([A-Za-z]+(?:[A-Z]\w+)+)|$tiki->{__wiki_links_handler}->($tiki,$1)|eg;
}

sub hdlr_interwiki_link {
	my $tiki = shift;
	my $in = shift;
	$tiki->{__interwiki_links_handler} ||= \&interwiki_link_default_processor;
	$$in =~ s|\[\[([:\w]+?)(?:\s+([^\]{2}]+?))?\]\]|$tiki->{__interwiki_links_handler}->($tiki,$1,$2)|eg;
}

sub wiki_link_default_processor {
	return qq|$_[1]|;
}

sub interwiki_link_default_processor {
	my $tiki = shift;
	my $link = shift;
	my $word = shift;
  	$link =~ m/^(\w+?):(.*)$/;
    my $interwiki = $tiki->{__interwiki_table}->{$1} || '';
    return qq{}.($word||$2).qq{};
}

#-- macro handling routines

sub macros { $_[0]->{__macro_processing}=$_[1]; }

{
	my %hdlr_types = ( 'block' =>1, 'block_post' =>1, 'inline'=>1, 'inline_literal'=>1 );
	sub macro_handler {
		my ($tiki, $name, $code, $type) = @_;
		unless ( defined( $hdlr_types{ $type } ) ) {
			my @types = keys %hdlr_types;
			die "Unknown macro handler type: $type\n Valid types: @types";
		}
		$tiki->{__macro_handlers}->{ $name } = { code => $code, type => $type };
	}
}

sub hdlr_macro_block { return $_[0]->macro_processor($_[1],'block'); }
sub hdlr_macro_block_postprocess { return $_[0]->macro_processor($_[1],'block_post'); }
sub hdlr_macro_inline { return $_[0]->inline_format( \$_[0]->macro_processor($_[1],'inline') ); }
sub hdlr_macro_inline_literal { return $_[0]->macro_processor($_[1],'inline_literal'); }

sub macro_processor {
	my $tiki = shift;
	my $in = shift;
	my $type = shift;
	my $out;
	$in = join ('', @{ $in } ) if ( ref($in) eq "ARRAY");
	$in=~/^%%(.*)%%/;
	my ($name, $attrib) = split(/\s/,$1,2);
	if ( defined( $tiki->{__macro_handlers}->{ $name } ) &&
			$tiki->{__macro_handlers}->{ $name }->{type} eq $type ) {
		$out = $tiki->{__macro_handlers}->{ $name }->{code}->($tiki, $name, $attrib);
	}
	return ($out || $in).($type=~/^block/?"\n":'');
}

#--- block handlers
# They get an array and pass decide whether to pass them on to be encoded or autolinked.

sub hdlr_paragraph {
	foreach my $line ( @{ $_[1] } ) {
		$line = $_[0]->inline_format( \$line );
	}
	return ''.join("",@{ $_[1] } )."\n";
}

sub hdlr_blockquote { return "\n" . $_[0]->block_format($_[1]) . "\n"; }

sub hdlr_pre {
	my $tiki = shift;
	foreach my $line ( @{ $_[0] } ) {
		$line = $tiki->inline_format( \$line );
	}
	return "\n". join("\n",@{ $_[0] }) ."\n\n";
}

sub hdlr_code_block {
	my $line = join("\n",@{ $_[1] });
	xml_encode( \$line );
	return "\n".$line."\n\n";
}

sub hdlr_hr { return ''.join("",@{ $_[1] } ); }
sub hdlr_h1 { return $_[0]->heading_processor($_[1]); }
sub hdlr_h2 { return $_[0]->heading_processor($_[1],'h2'); }
sub hdlr_h3 { return $_[0]->heading_processor($_[1],'h3'); }
sub hdlr_h4 { return $_[0]->heading_processor($_[1],'h4'); }
sub hdlr_h5 { return $_[0]->heading_processor($_[1],'h5'); }
sub hdlr_h6 { return $_[0]->heading_processor($_[1],'h6'); }
sub hdlr_ul { return $_[0]->list_processor($_[1]); }
sub hdlr_ol { return $_[0]->list_processor($_[1],'ol'); }

sub hdlr_dl {
	my $tiki = shift;
	my $content = shift;
	my $out="\n";
	foreach my $line ( @{ $content } ) {
		$line=~s/([;:])[\s\t]//;
		# Unlike other block handlers we do the striping because we have
		# two types of elements within this type.
		if ( $1 eq ':' ) {
			my @array = ( $line);
			$out .= "\n".$tiki->block_format( \@array )."\n";
		} else {
			$out .= ''.$tiki->inline_format( \$line )."\n";
		}
	}
	return $out."\n";
} # http://www.w3.org/TR/2003/WD-xhtml2-20030506/mod-list.html#s_listmodule

sub heading_processor {
	my $tiki = shift;
	my $heading = join("", @{ $_[0] } );
	my $id = join('', @{ $_[0] } );
	my $level = $_[1] || 'h1';
	$id =~ s/[^\s\w\d]+//g; # remove non alpha/ws characters
	$id =~ s/\b([a-z])/\u\L$1/g; # proper case all lower case characters at start of words
	# Using WikiWord format instead of Camel Case
	# $id =~ s/^\s*([A-Z]+)/\L$1/; # but first word is all lowercase
	$id =~ s/\s+//g; # Remove whitespace
	if ($tiki->{__heading_names}->{$id}) {
		my $count=2; # one is assumed.
		while ($tiki->{__heading_names}->{$id.$count}) { $count++; }
		$id.=$count;
	}
	$tiki->{__heading_names}->{$id}++;
	return "<$level>".$tiki->inline_format(\$heading)."\n";
}

sub list_processor {
	my $tiki = shift;
	my $content = shift;
	my $list_type = shift || 'ul';
	my $buffer;
	my $index = 0;
	$buffer->[$index]->{type}='_li';
	foreach my $line ( @{ $content } ) {
		my $symbol;
		unless ( $line=~s/^([*#])([\s\t]|(?=[*#]))// ) {
			$symbol = '_li';
		} else { $symbol = $1; }
		unless( $symbol eq $buffer->[$index]->{type} )  {
			$index++; $buffer->[$index]->{buffer}=(); $buffer->[$index]->{type}=$symbol;
		}
		push(@{ $buffer->[$index]->{buffer} },$line);
	}
	my $out = "<$list_type>\n";
	my $started = 0;
	foreach my $buffer ( @{ $buffer } ) {
		if ($buffer->{type} eq '_li') {
			foreach my $line ( @{ $buffer->{buffer} } ) {
				$out .= $started ? "\n" : '';
				$started++;
				$out .= $tiki->inline_format( \$line );
			}
		} else { $out .= "\n".$tiki->list_processor( $buffer->{buffer}, ( $buffer->{type} eq '*'?'ul':'ol' ) ); }
	}
	$out .= "\n";
	return $out."\n";
}

sub hdlr_table {
	my $tiki = shift;
	my $content = shift;
	my $out;
	foreach my $line (@{ $content }) {
		my $row='';
		my $colspan = 1;
		my $is_heading = 1 if $line=~s/^\|!/\|/;
		$line=~s/\|/ \|/g; # quick hack that inserts a space and get "blanks cells" to register.
		my @cells = split(/\|/,$line);
		foreach my $cell (reverse @cells) { # work backward to calculate colspans.
			$cell=~s!^($cell_alignment)!!;
			my $alignment = $cell_alignments{$1} if $1;
			if ( $cell ) { $cell=~s/^\s*//; $cell=~s/\s*$//; }# clean out leading and tailing whitespace.
			unless( $cell ) { $colspan++; }
			else {
				my $encoded = ( defined($is_heading)?'
					( defined($alignment)?" align=\"$alignment\"":'' ) .
					( $colspan>1?" colspan=\"$colspan\"":'' ) .
					'>';
				$encoded .= $tiki->inline_format( \$cell );
				$encoded .= (defined($is_heading)?'':'
				$row = $encoded . "\n" . $row;
				$colspan = 1;
			}
		}
		$out .= "
	}
	return "\n".$out."\n";
}


#--- inline handlers
# Handler functions gets scalar (reference?) and is assumed to parse the string from the start and strip
# is entirely from the referenced string. If nothing is found return undef in the first position.)

sub hdlr_strong { return ${$_[1]}=~s/^\*(.+?)\*${term}//?('', $1,''):undef; }
sub hdlr_emp { return ${$_[1]}=~s!^/(.+?)/${term}!!?('', $1,''):undef; }
sub hdlr_insert { return ${$_[1]}=~s/^\+(.+?)\+${term}//?('', $1,''):undef; }
sub hdlr_delete { return ${$_[1]}=~s/^\-(.+?)\b\-${term}//?('', $1,''):undef; } # added \b to fix "greedy problem."
sub hdlr_subscript { return ${$_[1]}=~s/^\~(.+?)\~${term}//?('', $1,''):undef; }
sub hdlr_superscript { return ${$_[1]}=~s/^\^(.+?)\^${term}//?('', $1,''):undef; }
sub hdlr_quote { return ${$_[1]}=~s/^\"(.+?)\"${term}//?('', $1,''):undef; }
sub hdlr_code_inline { return ${$_[1]}=~s/^\%(.+?)\%${term}//?('', $1,''):undef; }
sub hdlr_cite { return ${$_[1]}=~s/^\@(.+?)\@${term}//?('', $1,''):undef; }

sub hdlr_hyperlink { return ${$_[1]}=~s!^\[([^\]]*)\]:(.*?)${term}!!?("",$1,''):undef; }
sub hdlr_image { return ${$_[1]}=~s!^\{([^\}]*)\}:(.*?)${term}!!?("",'',''):undef; }

sub hdlr_autolink {
	${$_[1]}=~s#(?:^|(?<=\s))((?:$protocol):\S+[\w/])(?=${term})#$1#go;
	while ( ${$_[1]}=~m/(?:^|(?<=\s))((?:mailto:)?)([^\s",\@]*\@[^\s.,]+\.[^\s,]+)(?=${term})/ ) {
		my $matched = "$1$2";
		my ($prefix, $mailto) = ($1, $2 );
		$mailto=~s/\@/@/; $mailto=~s/\././g;
		my $email = $mailto;
		$email=~s/&/__AMP__/g; #uses amp markers to avoid encoding confusion in display.
		${$_[1]}=~s!$matched!$prefix$email!gi
	}
}

sub hdlr_acronym {
	${$_[1]}=~s!\b([A-Z][A-Z0-9]*)\(([^\)]+?)\)${term}!$1!go; # Needs to be more inclusive?
}

#--- encoding

sub encoding_processor {
	my $line = shift;
	my $attribs = shift;
	my $c;
	my $tp = defined( $attribs->{typographic_processing} )?$attribs->{typographic_processing}:1;
	while ( $$line=~m/($not_in_markup)/g ) { #|<[^>]*\/>
		my $t=$1;
		unless ($t=~/^
			xml_encode(\$t);
			typographic_encode(\$t) if ($tp);
		}
		$c.=$t;
	}
	$$line=$c;
}

sub xml_encode { # Splitting this out is particularly helpful to CODE blocks.
	${$_[0]}=~s/__LT__//g; # reverse markers.
	${$_[0]}=~s!($RE)!$Map{$1}!g;
	${$_[0]}=~s{([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)}{xml_utf8_decode($1)}egs;
	${$_[0]}=~s/__AMP__/&/g; #reverse amp spam protect markers
	return ${$_[0]}; # hack for CODE blocks.
}

sub xml_utf8_decode {
	my ($str, $hex) = @_;
    my $len = length ($str);
    my $n;
    if ($len == 2) {
		my @n = unpack "C2", $str;
		$n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f);
	} elsif ($len == 3) {
		my @n = unpack "C3", $str;
		$n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) + ($n[2] & 0x3f);
    } elsif ($len == 4) {
		my @n = unpack "C4", $str;
		$n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12)
		+ (($n[2] & 0x3f) << 6) + ($n[3] & 0x3f);
    } elsif ($len == 1) { $n = ord ($str); # just to be complete...
    } else { warn "bad value [$str] for xml_utf8_decode"; }
    return $hex ? sprintf ("&#x%x;", $n) : "&#$n;";
}

sub typographic_encode {
	${$_[0]}=~s!(^|(?<=\s))---(?=\s?)!—!go;
	${$_[0]}=~s!(^|(?<=\s))--(?=\s?)!–!go;
	${$_[0]}=~s!(^|\B)\.\.\.\b!…!go;
	${$_[0]}=~s!\b\.\.\.(?=[\s\t]|$)!…!go;
	${$_[0]}=~s!\(R\)(?=\s?)!®!go;
	${$_[0]}=~s!\(TM\)(?=${term})!™!go;
	${$_[0]}=~s!\(C\)(?=${term})!©!go;
	${$_[0]}=~s!(^|(?<=\s))1/4(?=${term})!¼!go;
	${$_[0]}=~s!(^|(?<=\s))1/2(?=${term})!½!go;
	${$_[0]}=~s!(^|(?<=\s))3/4(?=${term})!¾!go;
	${$_[0]}=~s!\b(\d+)\s?x\s?(\d+)\b!$1×$2!go;
}

1;

__END__